1/* 2 * tcltklib.c 3 * Aug. 27, 1997 Y. Shigehiro 4 * Oct. 24, 1997 Y. Matsumoto 5 */ 6 7#define TCLTKLIB_RELEASE_DATE "2010-08-25" 8/* #define CREATE_RUBYTK_KIT */ 9 10#include "ruby.h" 11 12#ifdef HAVE_RUBY_ENCODING_H 13#include "ruby/encoding.h" 14#endif 15#ifndef RUBY_VERSION 16#define RUBY_VERSION "(unknown version)" 17#endif 18#ifndef RUBY_RELEASE_DATE 19#define RUBY_RELEASE_DATE "unknown release-date" 20#endif 21 22#ifdef RUBY_VM 23static int rb_thread_critical; /* dummy */ 24int rb_thread_check_trap_pending(); 25#else 26/* use rb_thread_critical on Ruby 1.8.x */ 27#include "rubysig.h" 28#endif 29 30#if !defined(RSTRING_PTR) 31#define RSTRING_PTR(s) (RSTRING(s)->ptr) 32#define RSTRING_LEN(s) (RSTRING(s)->len) 33#endif 34#if !defined(RSTRING_LENINT) 35#define RSTRING_LENINT(s) ((int)RSTRING_LEN(s)) 36#endif 37#if !defined(RARRAY_PTR) 38#define RARRAY_PTR(s) (RARRAY(s)->ptr) 39#define RARRAY_LEN(s) (RARRAY(s)->len) 40#endif 41 42#ifdef OBJ_UNTRUST 43#define RbTk_OBJ_UNTRUST(x) do {OBJ_TAINT(x); OBJ_UNTRUST(x);} while (0) 44#else 45#define RbTk_OBJ_UNTRUST(x) OBJ_TAINT(x) 46#endif 47#define RbTk_ALLOC_N(type, n) (type *)ckalloc((int)(sizeof(type) * (n))) 48 49#if defined(HAVE_RB_PROC_NEW) && !defined(RUBY_VM) 50/* Ruby 1.8 :: rb_proc_new() was hidden from intern.h at 2008/04/22 */ 51extern VALUE rb_proc_new _((VALUE (*)(ANYARGS/* VALUE yieldarg[, VALUE procarg] */), VALUE)); 52#endif 53 54#undef EXTERN /* avoid conflict with tcl.h of tcl8.2 or before */ 55#include <stdio.h> 56#ifdef HAVE_STDARG_PROTOTYPES 57#include <stdarg.h> 58#define va_init_list(a,b) va_start(a,b) 59#else 60#include <varargs.h> 61#define va_init_list(a,b) va_start(a) 62#endif 63#include <string.h> 64 65#if !defined HAVE_VSNPRINTF && !defined vsnprintf 66# ifdef WIN32 67 /* In Win32, vsnprintf is available as the "non-ANSI" _vsnprintf. */ 68# define vsnprintf _vsnprintf 69# else 70# ifdef HAVE_RUBY_RUBY_H 71# include "ruby/missing.h" 72# else 73# include "missing.h" 74# endif 75# endif 76#endif 77 78#include <tcl.h> 79#include <tk.h> 80 81#ifndef HAVE_RUBY_NATIVE_THREAD_P 82#define ruby_native_thread_p() is_ruby_native_thread() 83#undef RUBY_USE_NATIVE_THREAD 84#else 85#define RUBY_USE_NATIVE_THREAD 1 86#endif 87 88#ifndef HAVE_RB_ERRINFO 89#define rb_errinfo() (ruby_errinfo+0) /* cannot be l-value */ 90#else 91VALUE rb_errinfo(void); 92#endif 93#ifndef HAVE_RB_SAFE_LEVEL 94#define rb_safe_level() (ruby_safe_level+0) 95#endif 96#ifndef HAVE_RB_SOURCEFILE 97#define rb_sourcefile() (ruby_sourcefile+0) 98#endif 99 100#include "stubs.h" 101 102#ifndef TCL_ALPHA_RELEASE 103#define TCL_ALPHA_RELEASE 0 /* "alpha" */ 104#define TCL_BETA_RELEASE 1 /* "beta" */ 105#define TCL_FINAL_RELEASE 2 /* "final" */ 106#endif 107 108static struct { 109 int major; 110 int minor; 111 int type; /* ALPHA==0, BETA==1, FINAL==2 */ 112 int patchlevel; 113} tcltk_version = {0, 0, 0, 0}; 114 115static void 116set_tcltk_version() 117{ 118 if (tcltk_version.major) return; 119 120 Tcl_GetVersion(&(tcltk_version.major), 121 &(tcltk_version.minor), 122 &(tcltk_version.patchlevel), 123 &(tcltk_version.type)); 124} 125 126#if TCL_MAJOR_VERSION >= 8 127# ifndef CONST84 128# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 4 /* Tcl8.0.x -- 8.4b1 */ 129# define CONST84 130# else /* unknown (maybe TCL_VERSION >= 8.5) */ 131# ifdef CONST 132# define CONST84 CONST 133# else 134# define CONST84 135# endif 136# endif 137# endif 138#else /* TCL_MAJOR_VERSION < 8 */ 139# ifdef CONST 140# define CONST84 CONST 141# else 142# define CONST 143# define CONST84 144# endif 145#endif 146 147#ifndef CONST86 148# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 5 /* Tcl8.0.x -- 8.5.x */ 149# define CONST86 150# else 151# define CONST86 CONST84 152# endif 153#endif 154 155/* copied from eval.c */ 156#define TAG_RETURN 0x1 157#define TAG_BREAK 0x2 158#define TAG_NEXT 0x3 159#define TAG_RETRY 0x4 160#define TAG_REDO 0x5 161#define TAG_RAISE 0x6 162#define TAG_THROW 0x7 163#define TAG_FATAL 0x8 164 165/* for ruby_debug */ 166#define DUMP1(ARG1) if (ruby_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1); fflush(stderr); } 167#define DUMP2(ARG1, ARG2) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\ 168fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); fflush(stderr); } 169#define DUMP3(ARG1, ARG2, ARG3) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\ 170fprintf(stderr, ARG1, ARG2, ARG3); fprintf(stderr, "\n"); fflush(stderr); } 171/* 172#define DUMP1(ARG1) 173#define DUMP2(ARG1, ARG2) 174#define DUMP3(ARG1, ARG2, ARG3) 175*/ 176 177/* release date */ 178static const char tcltklib_release_date[] = TCLTKLIB_RELEASE_DATE; 179 180/* finalize_proc_name */ 181static const char finalize_hook_name[] = "INTERP_FINALIZE_HOOK"; 182 183static void ip_finalize _((Tcl_Interp*)); 184 185static int at_exit = 0; 186 187#ifdef HAVE_RUBY_ENCODING_H 188static VALUE cRubyEncoding; 189 190/* encoding */ 191static int ENCODING_INDEX_UTF8; 192static int ENCODING_INDEX_BINARY; 193#endif 194static VALUE ENCODING_NAME_UTF8; 195static VALUE ENCODING_NAME_BINARY; 196 197static VALUE create_dummy_encoding_for_tk_core _((VALUE, VALUE, VALUE)); 198static VALUE create_dummy_encoding_for_tk _((VALUE, VALUE)); 199static int update_encoding_table _((VALUE, VALUE, VALUE)); 200static VALUE encoding_table_get_name_core _((VALUE, VALUE, VALUE)); 201static VALUE encoding_table_get_obj_core _((VALUE, VALUE, VALUE)); 202static VALUE encoding_table_get_name _((VALUE, VALUE)); 203static VALUE encoding_table_get_obj _((VALUE, VALUE)); 204static VALUE create_encoding_table _((VALUE)); 205static VALUE ip_get_encoding_table _((VALUE)); 206 207 208/* for callback break & continue */ 209static VALUE eTkCallbackReturn; 210static VALUE eTkCallbackBreak; 211static VALUE eTkCallbackContinue; 212 213static VALUE eLocalJumpError; 214 215static VALUE eTkLocalJumpError; 216static VALUE eTkCallbackRetry; 217static VALUE eTkCallbackRedo; 218static VALUE eTkCallbackThrow; 219 220static VALUE tcltkip_class; 221 222static ID ID_at_enc; 223static ID ID_at_interp; 224 225static ID ID_encoding_name; 226static ID ID_encoding_table; 227 228static ID ID_stop_p; 229static ID ID_alive_p; 230static ID ID_kill; 231static ID ID_join; 232static ID ID_value; 233 234static ID ID_call; 235static ID ID_backtrace; 236static ID ID_message; 237 238static ID ID_at_reason; 239static ID ID_return; 240static ID ID_break; 241static ID ID_next; 242 243static ID ID_to_s; 244static ID ID_inspect; 245 246static VALUE ip_invoke_real _((int, VALUE*, VALUE)); 247static VALUE ip_invoke _((int, VALUE*, VALUE)); 248static VALUE ip_invoke_with_position _((int, VALUE*, VALUE, Tcl_QueuePosition)); 249static VALUE tk_funcall _((VALUE(), int, VALUE*, VALUE)); 250static VALUE callq_safelevel_handler _((VALUE, VALUE)); 251 252/* Tcl's object type */ 253#if TCL_MAJOR_VERSION >= 8 254static const char Tcl_ObjTypeName_ByteArray[] = "bytearray"; 255static CONST86 Tcl_ObjType *Tcl_ObjType_ByteArray; 256 257static const char Tcl_ObjTypeName_String[] = "string"; 258static CONST86 Tcl_ObjType *Tcl_ObjType_String; 259 260#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1) 261#define IS_TCL_BYTEARRAY(obj) ((obj)->typePtr == Tcl_ObjType_ByteArray) 262#define IS_TCL_STRING(obj) ((obj)->typePtr == Tcl_ObjType_String) 263#define IS_TCL_VALID_STRING(obj) ((obj)->bytes != (char*)NULL) 264#endif 265#endif 266 267#ifndef HAVE_RB_HASH_LOOKUP 268#define rb_hash_lookup rb_hash_aref 269#endif 270 271/* safe Tcl_Eval and Tcl_GlobalEval */ 272static int 273#ifdef HAVE_PROTOTYPES 274tcl_eval(Tcl_Interp *interp, const char *cmd) 275#else 276tcl_eval(interp, cmd) 277 Tcl_Interp *interp; 278 const char *cmd; /* don't have to be writable */ 279#endif 280{ 281 char *buf = strdup(cmd); 282 int ret; 283 284 Tcl_AllowExceptions(interp); 285 ret = Tcl_Eval(interp, buf); 286 free(buf); 287 return ret; 288} 289 290#undef Tcl_Eval 291#define Tcl_Eval tcl_eval 292 293static int 294#ifdef HAVE_PROTOTYPES 295tcl_global_eval(Tcl_Interp *interp, const char *cmd) 296#else 297tcl_global_eval(interp, cmd) 298 Tcl_Interp *interp; 299 const char *cmd; /* don't have to be writable */ 300#endif 301{ 302 char *buf = strdup(cmd); 303 int ret; 304 305 Tcl_AllowExceptions(interp); 306 ret = Tcl_GlobalEval(interp, buf); 307 free(buf); 308 return ret; 309} 310 311#undef Tcl_GlobalEval 312#define Tcl_GlobalEval tcl_global_eval 313 314/* Tcl_{Incr|Decr}RefCount for tcl7.x or earlier */ 315#if TCL_MAJOR_VERSION < 8 316#define Tcl_IncrRefCount(obj) (1) 317#define Tcl_DecrRefCount(obj) (1) 318#endif 319 320/* Tcl_GetStringResult for tcl7.x or earlier */ 321#if TCL_MAJOR_VERSION < 8 322#define Tcl_GetStringResult(interp) ((interp)->result) 323#endif 324 325/* Tcl_[GS]etVar2Ex for tcl8.0 */ 326#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 327static Tcl_Obj * 328Tcl_GetVar2Ex(interp, name1, name2, flags) 329 Tcl_Interp *interp; 330 CONST char *name1; 331 CONST char *name2; 332 int flags; 333{ 334 Tcl_Obj *nameObj1, *nameObj2 = NULL, *retObj; 335 336 nameObj1 = Tcl_NewStringObj((char*)name1, -1); 337 Tcl_IncrRefCount(nameObj1); 338 339 if (name2) { 340 nameObj2 = Tcl_NewStringObj((char*)name2, -1); 341 Tcl_IncrRefCount(nameObj2); 342 } 343 344 retObj = Tcl_ObjGetVar2(interp, nameObj1, nameObj2, flags); 345 346 if (name2) { 347 Tcl_DecrRefCount(nameObj2); 348 } 349 350 Tcl_DecrRefCount(nameObj1); 351 352 return retObj; 353} 354 355static Tcl_Obj * 356Tcl_SetVar2Ex(interp, name1, name2, newValObj, flags) 357 Tcl_Interp *interp; 358 CONST char *name1; 359 CONST char *name2; 360 Tcl_Obj *newValObj; 361 int flags; 362{ 363 Tcl_Obj *nameObj1, *nameObj2 = NULL, *retObj; 364 365 nameObj1 = Tcl_NewStringObj((char*)name1, -1); 366 Tcl_IncrRefCount(nameObj1); 367 368 if (name2) { 369 nameObj2 = Tcl_NewStringObj((char*)name2, -1); 370 Tcl_IncrRefCount(nameObj2); 371 } 372 373 retObj = Tcl_ObjSetVar2(interp, nameObj1, nameObj2, newValObj, flags); 374 375 if (name2) { 376 Tcl_DecrRefCount(nameObj2); 377 } 378 379 Tcl_DecrRefCount(nameObj1); 380 381 return retObj; 382} 383#endif 384 385/* from tkAppInit.c */ 386 387#if TCL_MAJOR_VERSION < 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 4) 388# if !defined __MINGW32__ && !defined __BORLANDC__ 389/* 390 * The following variable is a special hack that is needed in order for 391 * Sun shared libraries to be used for Tcl. 392 */ 393 394extern int matherr(); 395int *tclDummyMathPtr = (int *) matherr; 396# endif 397#endif 398 399/*---- module TclTkLib ----*/ 400 401struct invoke_queue { 402 Tcl_Event ev; 403 int argc; 404#if TCL_MAJOR_VERSION >= 8 405 Tcl_Obj **argv; 406#else /* TCL_MAJOR_VERSION < 8 */ 407 char **argv; 408#endif 409 VALUE interp; 410 int *done; 411 int safe_level; 412 VALUE result; 413 VALUE thread; 414}; 415 416struct eval_queue { 417 Tcl_Event ev; 418 char *str; 419 int len; 420 VALUE interp; 421 int *done; 422 int safe_level; 423 VALUE result; 424 VALUE thread; 425}; 426 427struct call_queue { 428 Tcl_Event ev; 429 VALUE (*func)(); 430 int argc; 431 VALUE *argv; 432 VALUE interp; 433 int *done; 434 int safe_level; 435 VALUE result; 436 VALUE thread; 437}; 438 439void 440invoke_queue_mark(struct invoke_queue *q) 441{ 442 rb_gc_mark(q->interp); 443 rb_gc_mark(q->result); 444 rb_gc_mark(q->thread); 445} 446 447void 448eval_queue_mark(struct eval_queue *q) 449{ 450 rb_gc_mark(q->interp); 451 rb_gc_mark(q->result); 452 rb_gc_mark(q->thread); 453} 454 455void 456call_queue_mark(struct call_queue *q) 457{ 458 int i; 459 460 for(i = 0; i < q->argc; i++) { 461 rb_gc_mark(q->argv[i]); 462 } 463 464 rb_gc_mark(q->interp); 465 rb_gc_mark(q->result); 466 rb_gc_mark(q->thread); 467} 468 469 470static VALUE eventloop_thread; 471static Tcl_Interp *eventloop_interp; 472#ifdef RUBY_USE_NATIVE_THREAD 473Tcl_ThreadId tk_eventloop_thread_id; /* native thread ID of Tcl interpreter */ 474#endif 475static VALUE eventloop_stack; 476static int window_event_mode = ~0; 477 478static VALUE watchdog_thread; 479 480Tcl_Interp *current_interp; 481 482/* thread control strategy */ 483/* multi-tk works with the following settings only ??? 484 : CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1 485 : USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0 486 : DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 0 487*/ 488#ifdef RUBY_USE_NATIVE_THREAD 489#define CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1 490#define USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0 491#define DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 1 492#else /* ! RUBY_USE_NATIVE_THREAD */ 493#define CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 1 494#define USE_TOGGLE_WINDOW_MODE_FOR_IDLE 0 495#define DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 0 496#endif 497 498#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 499static int have_rb_thread_waiting_for_value = 0; 500#endif 501 502/* 503 * 'event_loop_max' is a maximum events which the eventloop processes in one 504 * term of thread scheduling. 'no_event_tick' is the count-up value when 505 * there are no event for processing. 506 * 'timer_tick' is a limit of one term of thread scheduling. 507 * If 'timer_tick' == 0, then not use the timer for thread scheduling. 508 */ 509#ifdef RUBY_USE_NATIVE_THREAD 510#define DEFAULT_EVENT_LOOP_MAX 800/*counts*/ 511#define DEFAULT_NO_EVENT_TICK 10/*counts*/ 512#define DEFAULT_NO_EVENT_WAIT 5/*milliseconds ( 1 -- 999 ) */ 513#define WATCHDOG_INTERVAL 10/*milliseconds ( 1 -- 999 ) */ 514#define DEFAULT_TIMER_TICK 0/*milliseconds ( 0 -- 999 ) */ 515#define NO_THREAD_INTERRUPT_TIME 100/*milliseconds ( 1 -- 999 ) */ 516#else /* ! RUBY_USE_NATIVE_THREAD */ 517#define DEFAULT_EVENT_LOOP_MAX 800/*counts*/ 518#define DEFAULT_NO_EVENT_TICK 10/*counts*/ 519#define DEFAULT_NO_EVENT_WAIT 20/*milliseconds ( 1 -- 999 ) */ 520#define WATCHDOG_INTERVAL 10/*milliseconds ( 1 -- 999 ) */ 521#define DEFAULT_TIMER_TICK 0/*milliseconds ( 0 -- 999 ) */ 522#define NO_THREAD_INTERRUPT_TIME 100/*milliseconds ( 1 -- 999 ) */ 523#endif 524 525#define EVENT_HANDLER_TIMEOUT 100/*milliseconds*/ 526 527static int event_loop_max = DEFAULT_EVENT_LOOP_MAX; 528static int no_event_tick = DEFAULT_NO_EVENT_TICK; 529static int no_event_wait = DEFAULT_NO_EVENT_WAIT; 530static int timer_tick = DEFAULT_TIMER_TICK; 531static int req_timer_tick = DEFAULT_TIMER_TICK; 532static int run_timer_flag = 0; 533 534static int event_loop_wait_event = 0; 535static int event_loop_abort_on_exc = 1; 536static int loop_counter = 0; 537 538static int check_rootwidget_flag = 0; 539 540 541/* call ruby interpreter */ 542#if TCL_MAJOR_VERSION >= 8 543static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*)); 544static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*)); 545#else /* TCL_MAJOR_VERSION < 8 */ 546static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, char **)); 547static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, char **)); 548#endif 549 550struct cmd_body_arg { 551 VALUE receiver; 552 ID method; 553 VALUE args; 554}; 555 556/*----------------------------*/ 557/* use Tcl internal functions */ 558/*----------------------------*/ 559#ifndef TCL_NAMESPACE_DEBUG 560#define TCL_NAMESPACE_DEBUG 0 561#endif 562 563#if TCL_NAMESPACE_DEBUG 564 565#if TCL_MAJOR_VERSION >= 8 566EXTERN struct TclIntStubs *tclIntStubsPtr; 567#endif 568 569/*-- Tcl_GetCurrentNamespace --*/ 570#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 5 571/* Tcl7.x doesn't have namespace support. */ 572/* Tcl8.5+ has definition of Tcl_GetCurrentNamespace() in tclDecls.h */ 573# ifndef Tcl_GetCurrentNamespace 574EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace _((Tcl_Interp *)); 575# endif 576# if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) 577# ifndef Tcl_GetCurrentNamespace 578# ifndef FunctionNum_of_GetCurrentNamespace 579#define FunctionNum_of_GetCurrentNamespace 124 580# endif 581struct DummyTclIntStubs_for_GetCurrentNamespace { 582 int magic; 583 struct TclIntStubHooks *hooks; 584 void (*func[FunctionNum_of_GetCurrentNamespace])(); 585 Tcl_Namespace * (*tcl_GetCurrentNamespace) _((Tcl_Interp *)); 586}; 587 588#define Tcl_GetCurrentNamespace \ 589 (((struct DummyTclIntStubs_for_GetCurrentNamespace *)tclIntStubsPtr)->tcl_GetCurrentNamespace) 590# endif 591# endif 592#endif 593 594/* namespace check */ 595/* ip_null_namespace(Tcl_Interp *interp) */ 596#if TCL_MAJOR_VERSION < 8 597#define ip_null_namespace(interp) (0) 598#else /* support namespace */ 599#define ip_null_namespace(interp) \ 600 (Tcl_GetCurrentNamespace(interp) == (Tcl_Namespace *)NULL) 601#endif 602 603/* rbtk_invalid_namespace(tcltkip *ptr) */ 604#if TCL_MAJOR_VERSION < 8 605#define rbtk_invalid_namespace(ptr) (0) 606#else /* support namespace */ 607#define rbtk_invalid_namespace(ptr) \ 608 ((ptr)->default_ns == (Tcl_Namespace*)NULL || Tcl_GetCurrentNamespace((ptr)->ip) != (ptr)->default_ns) 609#endif 610 611/*-- Tcl_PopCallFrame & Tcl_PushCallFrame --*/ 612#if TCL_MAJOR_VERSION >= 8 613# ifndef CallFrame 614typedef struct CallFrame { 615 Tcl_Namespace *nsPtr; 616 int dummy1; 617 int dummy2; 618 char *dummy3; 619 struct CallFrame *callerPtr; 620 struct CallFrame *callerVarPtr; 621 int level; 622 char *dummy7; 623 char *dummy8; 624 int dummy9; 625 char* dummy10; 626} CallFrame; 627# endif 628 629# if !defined(TclGetFrame) && !defined(TclGetFrame_TCL_DECLARED) 630EXTERN int TclGetFrame _((Tcl_Interp *, CONST char *, CallFrame **)); 631# endif 632# if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) 633# ifndef TclGetFrame 634# ifndef FunctionNum_of_GetFrame 635#define FunctionNum_of_GetFrame 32 636# endif 637struct DummyTclIntStubs_for_GetFrame { 638 int magic; 639 struct TclIntStubHooks *hooks; 640 void (*func[FunctionNum_of_GetFrame])(); 641 int (*tclGetFrame) _((Tcl_Interp *, CONST char *, CallFrame **)); 642}; 643#define TclGetFrame \ 644 (((struct DummyTclIntStubs_for_GetFrame *)tclIntStubsPtr)->tclGetFrame) 645# endif 646# endif 647 648# if !defined(Tcl_PopCallFrame) && !defined(Tcl_PopCallFrame_TCL_DECLARED) 649EXTERN void Tcl_PopCallFrame _((Tcl_Interp *)); 650EXTERN int Tcl_PushCallFrame _((Tcl_Interp *, Tcl_CallFrame *, Tcl_Namespace *, int)); 651# endif 652# if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) 653# ifndef Tcl_PopCallFrame 654# ifndef FunctionNum_of_PopCallFrame 655#define FunctionNum_of_PopCallFrame 128 656# endif 657struct DummyTclIntStubs_for_PopCallFrame { 658 int magic; 659 struct TclIntStubHooks *hooks; 660 void (*func[FunctionNum_of_PopCallFrame])(); 661 void (*tcl_PopCallFrame) _((Tcl_Interp *)); 662 int (*tcl_PushCallFrame) _((Tcl_Interp *, Tcl_CallFrame *, Tcl_Namespace *, int)); 663}; 664 665#define Tcl_PopCallFrame \ 666 (((struct DummyTclIntStubs_for_PopCallFrame *)tclIntStubsPtr)->tcl_PopCallFrame) 667#define Tcl_PushCallFrame \ 668 (((struct DummyTclIntStubs_for_PopCallFrame *)tclIntStubsPtr)->tcl_PushCallFrame) 669# endif 670# endif 671 672#else /* Tcl7.x */ 673# ifndef CallFrame 674typedef struct CallFrame { 675 Tcl_HashTable varTable; 676 int level; 677 int argc; 678 char **argv; 679 struct CallFrame *callerPtr; 680 struct CallFrame *callerVarPtr; 681} CallFrame; 682# endif 683# ifndef Tcl_CallFrame 684#define Tcl_CallFrame CallFrame 685# endif 686 687# if !defined(TclGetFrame) && !defined(TclGetFrame_TCL_DECLARED) 688EXTERN int TclGetFrame _((Tcl_Interp *, CONST char *, CallFrame **)); 689# endif 690 691# if !defined(Tcl_PopCallFrame) && !defined(Tcl_PopCallFrame_TCL_DECLARED) 692typedef struct DummyInterp { 693 char *dummy1; 694 char *dummy2; 695 int dummy3; 696 Tcl_HashTable dummy4; 697 Tcl_HashTable dummy5; 698 Tcl_HashTable dummy6; 699 int numLevels; 700 int maxNestingDepth; 701 CallFrame *framePtr; 702 CallFrame *varFramePtr; 703} DummyInterp; 704 705static void 706Tcl_PopCallFrame(interp) 707 Tcl_Interp *interp; 708{ 709 DummyInterp *iPtr = (DummyInterp*)interp; 710 CallFrame *frame = iPtr->varFramePtr; 711 712 /* **** DUMMY **** */ 713 iPtr->framePtr = frame.callerPtr; 714 iPtr->varFramePtr = frame.callerVarPtr; 715 716 return TCL_OK; 717} 718 719/* dummy */ 720#define Tcl_Namespace char 721 722static int 723Tcl_PushCallFrame(interp, framePtr, nsPtr, isProcCallFrame) 724 Tcl_Interp *interp; 725 Tcl_CallFrame *framePtr; 726 Tcl_Namespace *nsPtr; 727 int isProcCallFrame; 728{ 729 DummyInterp *iPtr = (DummyInterp*)interp; 730 CallFrame *frame = (CallFrame *)framePtr; 731 732 /* **** DUMMY **** */ 733 Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS); 734 if (iPtr->varFramePtr != NULL) { 735 frame.level = iPtr->varFramePtr->level + 1; 736 } else { 737 frame.level = 1; 738 } 739 frame.callerPtr = iPtr->framePtr; 740 frame.callerVarPtr = iPtr->varFramePtr; 741 iPtr->framePtr = &frame; 742 iPtr->varFramePtr = &frame; 743 744 return TCL_OK; 745} 746# endif 747 748#endif 749 750#endif /* TCL_NAMESPACE_DEBUG */ 751 752 753/*---- class TclTkIp ----*/ 754struct tcltkip { 755 Tcl_Interp *ip; /* the interpreter */ 756#if TCL_NAMESPACE_DEBUG 757 Tcl_Namespace *default_ns; /* default namespace */ 758#endif 759#ifdef RUBY_USE_NATIVE_THREAD 760 Tcl_ThreadId tk_thread_id; /* native thread ID of Tcl interpreter */ 761#endif 762 int has_orig_exit; /* has original 'exit' command ? */ 763 Tcl_CmdInfo orig_exit_info; /* command info of original 'exit' command */ 764 int ref_count; /* reference count of rbtk_preserve_ip call */ 765 int allow_ruby_exit; /* allow exiting ruby by 'exit' function */ 766 int return_value; /* return value */ 767}; 768 769static struct tcltkip * 770get_ip(self) 771 VALUE self; 772{ 773 struct tcltkip *ptr; 774 775 Data_Get_Struct(self, struct tcltkip, ptr); 776 if (ptr == 0) { 777 /* rb_raise(rb_eTypeError, "uninitialized TclTkIp"); */ 778 return((struct tcltkip *)NULL); 779 } 780 if (ptr->ip == (Tcl_Interp*)NULL) { 781 /* rb_raise(rb_eRuntimeError, "deleted IP"); */ 782 return((struct tcltkip *)NULL); 783 } 784 return ptr; 785} 786 787static int 788deleted_ip(ptr) 789 struct tcltkip *ptr; 790{ 791 if (!ptr || !ptr->ip || Tcl_InterpDeleted(ptr->ip) 792#if TCL_NAMESPACE_DEBUG 793 || rbtk_invalid_namespace(ptr) 794#endif 795 ) { 796 DUMP1("ip is deleted"); 797 return 1; 798 } 799 return 0; 800} 801 802/* increment/decrement reference count of tcltkip */ 803static int 804rbtk_preserve_ip(ptr) 805 struct tcltkip *ptr; 806{ 807 ptr->ref_count++; 808 if (ptr->ip == (Tcl_Interp*)NULL) { 809 /* deleted IP */ 810 ptr->ref_count = 0; 811 } else { 812 Tcl_Preserve((ClientData)ptr->ip); 813 } 814 return(ptr->ref_count); 815} 816 817static int 818rbtk_release_ip(ptr) 819 struct tcltkip *ptr; 820{ 821 ptr->ref_count--; 822 if (ptr->ref_count < 0) { 823 ptr->ref_count = 0; 824 } else if (ptr->ip == (Tcl_Interp*)NULL) { 825 /* deleted IP */ 826 ptr->ref_count = 0; 827 } else { 828 Tcl_Release((ClientData)ptr->ip); 829 } 830 return(ptr->ref_count); 831} 832 833 834static VALUE 835#ifdef HAVE_STDARG_PROTOTYPES 836create_ip_exc(VALUE interp, VALUE exc, const char *fmt, ...) 837#else 838create_ip_exc(interp, exc, fmt, va_alist) 839 VALUE interp: 840 VALUE exc; 841 const char *fmt; 842 va_dcl 843#endif 844{ 845 va_list args; 846 VALUE msg; 847 VALUE einfo; 848 struct tcltkip *ptr = get_ip(interp); 849 850 va_init_list(args,fmt); 851 msg = rb_vsprintf(fmt, args); 852 va_end(args); 853 einfo = rb_exc_new3(exc, msg); 854 rb_ivar_set(einfo, ID_at_interp, interp); 855 if (ptr) { 856 Tcl_ResetResult(ptr->ip); 857 } 858 859 return einfo; 860} 861 862 863/*####################################################################*/ 864#if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT 865 866/*--------------------------------------------------------*/ 867 868#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 84 869#error Ruby/Tk-Kit requires Tcl/Tk8.4 or later. 870#endif 871 872/*--------------------------------------------------------*/ 873 874/* Many part of code to support Ruby/Tk-Kit is quoted from Tclkit. */ 875/* But, never ask Tclkit community about Ruby/Tk-Kit. */ 876/* Please ask Ruby (Ruby/Tk) community (e.g. "ruby-dev" mailing list). */ 877/* 878----<< license terms of TclKit (from kitgen's "README" file) >>--------------- 879The Tclkit-specific sources are license free, they just have a copyright. Hold 880the author(s) harmless and any lawful use is permitted. 881 882This does *not* apply to any of the sources of the other major Open Source 883Software used in Tclkit, which each have very liberal BSD/MIT-like licenses: 884 885 * Tcl/Tk, TclVFS, Thread, Vlerq, Zlib 886------------------------------------------------------------------------------ 887 */ 888/* Tcl/Tk stubs may work, but probably it is meaningless. */ 889#if defined USE_TCL_STUBS || defined USE_TK_STUBS 890# error Not support Tcl/Tk stubs with Ruby/Tk-Kit or Rubykit. 891#endif 892 893#ifndef KIT_INCLUDES_ZLIB 894#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 86 895#define KIT_INCLUDES_ZLIB 1 896#else 897#define KIT_INCLUDES_ZLIB 0 898#endif 899#endif 900 901#ifdef _WIN32 902#define WIN32_LEAN_AND_MEAN 903#include <windows.h> 904#undef WIN32_LEAN_AND_MEAN 905#endif 906 907#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 86 908EXTERN Tcl_Obj* TclGetStartupScriptPath(); 909EXTERN void TclSetStartupScriptPath _((Tcl_Obj*)); 910#define Tcl_GetStartupScript(encPtr) TclGetStartupScriptPath() 911#define Tcl_SetStartupScript(path,enc) TclSetStartupScriptPath(path) 912#endif 913#if !defined(TclSetPreInitScript) && !defined(TclSetPreInitScript_TCL_DECLARED) 914EXTERN char* TclSetPreInitScript _((char *)); 915#endif 916 917#ifndef KIT_INCLUDES_TK 918# define KIT_INCLUDES_TK 1 919#endif 920/* #define KIT_INCLUDES_ITCL 1 */ 921/* #define KIT_INCLUDES_THREAD 1 */ 922 923Tcl_AppInitProc Vfs_Init, Rechan_Init; 924#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85 925Tcl_AppInitProc Pwb_Init; 926#endif 927 928#ifdef KIT_LITE 929Tcl_AppInitProc Vlerq_Init, Vlerq_SafeInit; 930#else 931Tcl_AppInitProc Mk4tcl_Init; 932#endif 933 934#if defined TCL_THREADS && defined KIT_INCLUDES_THREAD 935Tcl_AppInitProc Thread_Init; 936#endif 937 938#if KIT_INCLUDES_ZLIB 939Tcl_AppInitProc Zlib_Init; 940#endif 941 942#ifdef KIT_INCLUDES_ITCL 943Tcl_AppInitProc Itcl_Init; 944#endif 945 946#ifdef _WIN32 947Tcl_AppInitProc Dde_Init, Dde_SafeInit, Registry_Init; 948#endif 949 950/*--------------------------------------------------------*/ 951 952#define RUBYTK_KITPATH_CONST_NAME "RUBYTK_KITPATH" 953 954static char *rubytk_kitpath = NULL; 955 956static char rubytkkit_preInitCmd[] = 957"proc tclKitPreInit {} {\n" 958 "rename tclKitPreInit {}\n" 959 "load {} rubytk_kitpath\n" 960#if KIT_INCLUDES_ZLIB 961 "catch {load {} zlib}\n" 962#endif 963#ifdef KIT_LITE 964 "load {} vlerq\n" 965 "namespace eval ::vlerq {}\n" 966 "if {[catch { vlerq open $::tcl::kitpath } ::vlerq::starkit_root]} {\n" 967 "set n -1\n" 968 "} else {\n" 969 "set files [vlerq get $::vlerq::starkit_root 0 dirs 0 files]\n" 970 "set n [lsearch [vlerq get $files * name] boot.tcl]\n" 971 "}\n" 972 "if {$n >= 0} {\n" 973 "array set a [vlerq get $files $n]\n" 974#else 975 "load {} Mk4tcl\n" 976#if defined KIT_VFS_WRITABLE && !defined CREATE_RUBYKIT 977 /* running command cannot open itself for writing */ 978 "mk::file open exe $::tcl::kitpath\n" 979#else 980 "mk::file open exe $::tcl::kitpath -readonly\n" 981#endif 982 "set n [mk::select exe.dirs!0.files name boot.tcl]\n" 983 "if {[llength $n] == 1} {\n" 984 "array set a [mk::get exe.dirs!0.files!$n]\n" 985#endif 986 "if {![info exists a(contents)]} { error {no boot.tcl file} }\n" 987 "if {$a(size) != [string length $a(contents)]} {\n" 988 "set a(contents) [zlib decompress $a(contents)]\n" 989 "}\n" 990 "if {$a(contents) eq \"\"} { error {empty boot.tcl} }\n" 991 "uplevel #0 $a(contents)\n" 992#if 0 993 "} elseif {[lindex $::argv 0] eq \"-init-\"} {\n" 994 "uplevel #0 { source [lindex $::argv 1] }\n" 995 "exit\n" 996#endif 997 "} else {\n" 998 /* When cannot find VFS data, try to use a real directory */ 999 "set vfsdir \"[file rootname $::tcl::kitpath].vfs\"\n" 1000 "if {[file isdirectory $vfsdir]} {\n" 1001 "set ::tcl_library [file join $vfsdir lib tcl$::tcl_version]\n" 1002 "set ::tcl_libPath [list $::tcl_library [file join $vfsdir lib]]\n" 1003 "catch {uplevel #0 [list source [file join $vfsdir config.tcl]]}\n" 1004 "uplevel #0 [list source [file join $::tcl_library init.tcl]]\n" 1005 "set ::auto_path $::tcl_libPath\n" 1006 "} else {\n" 1007 "error \"\n $::tcl::kitpath has no VFS data to start up\"\n" 1008 "}\n" 1009 "}\n" 1010"}\n" 1011"tclKitPreInit" 1012; 1013 1014#if 0 1015/* Not use this script. 1016 It's a memo to support an initScript for Tcl interpreters in the future. */ 1017static const char initScript[] = 1018"if {[file isfile [file join $::tcl::kitpath main.tcl]]} {\n" 1019 "if {[info commands console] != {}} { console hide }\n" 1020 "set tcl_interactive 0\n" 1021 "incr argc\n" 1022 "set argv [linsert $argv 0 $argv0]\n" 1023 "set argv0 [file join $::tcl::kitpath main.tcl]\n" 1024"} else continue\n" 1025; 1026#endif 1027 1028/*--------------------------------------------------------*/ 1029 1030static char* 1031set_rubytk_kitpath(const char *kitpath) 1032{ 1033 if (kitpath) { 1034 int len = (int)strlen(kitpath); 1035 if (rubytk_kitpath) { 1036 ckfree(rubytk_kitpath); 1037 } 1038 1039 rubytk_kitpath = (char *)ckalloc(len + 1); 1040 memcpy(rubytk_kitpath, kitpath, len); 1041 rubytk_kitpath[len] = '\0'; 1042 } 1043 return rubytk_kitpath; 1044} 1045 1046/*--------------------------------------------------------*/ 1047 1048#ifdef WIN32 1049#define DEV_NULL "NUL" 1050#else 1051#define DEV_NULL "/dev/null" 1052#endif 1053 1054static void 1055check_tclkit_std_channels() 1056{ 1057 Tcl_Channel chan; 1058 1059 /* 1060 * We need to verify if we have the standard channels and create them if 1061 * not. Otherwise internals channels may get used as standard channels 1062 * (like for encodings) and panic. 1063 */ 1064 chan = Tcl_GetStdChannel(TCL_STDIN); 1065 if (chan == NULL) { 1066 chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "r", 0); 1067 if (chan != NULL) { 1068 Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8"); 1069 } 1070 Tcl_SetStdChannel(chan, TCL_STDIN); 1071 } 1072 chan = Tcl_GetStdChannel(TCL_STDOUT); 1073 if (chan == NULL) { 1074 chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0); 1075 if (chan != NULL) { 1076 Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8"); 1077 } 1078 Tcl_SetStdChannel(chan, TCL_STDOUT); 1079 } 1080 chan = Tcl_GetStdChannel(TCL_STDERR); 1081 if (chan == NULL) { 1082 chan = Tcl_OpenFileChannel(NULL, DEV_NULL, "w", 0); 1083 if (chan != NULL) { 1084 Tcl_SetChannelOption(NULL, chan, "-encoding", "utf-8"); 1085 } 1086 Tcl_SetStdChannel(chan, TCL_STDERR); 1087 } 1088} 1089 1090/*--------------------------------------------------------*/ 1091 1092static int 1093rubytk_kitpathObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) 1094{ 1095 const char* str; 1096 if (objc == 2) { 1097 set_rubytk_kitpath(Tcl_GetString(objv[1])); 1098 } else if (objc > 2) { 1099 Tcl_WrongNumArgs(interp, 1, objv, "?path?"); 1100 } 1101 str = rubytk_kitpath ? rubytk_kitpath : Tcl_GetNameOfExecutable(); 1102 Tcl_SetObjResult(interp, Tcl_NewStringObj(str, -1)); 1103 return TCL_OK; 1104} 1105 1106/* 1107 * Public entry point for ::tcl::kitpath. 1108 * Creates both link variable name and Tcl command ::tcl::kitpath. 1109 */ 1110static int 1111rubytk_kitpath_init(Tcl_Interp *interp) 1112{ 1113 Tcl_CreateObjCommand(interp, "::tcl::kitpath", rubytk_kitpathObjCmd, 0, 0); 1114 if (Tcl_LinkVar(interp, "::tcl::kitpath", (char *) &rubytk_kitpath, 1115 TCL_LINK_STRING | TCL_LINK_READ_ONLY) != TCL_OK) { 1116 Tcl_ResetResult(interp); 1117 } 1118 1119 Tcl_CreateObjCommand(interp, "::tcl::rubytk_kitpath", rubytk_kitpathObjCmd, 0, 0); 1120 if (Tcl_LinkVar(interp, "::tcl::rubytk_kitpath", (char *) &rubytk_kitpath, 1121 TCL_LINK_STRING | TCL_LINK_READ_ONLY) != TCL_OK) { 1122 Tcl_ResetResult(interp); 1123 } 1124 1125 if (rubytk_kitpath == NULL) { 1126 /* 1127 * XXX: We may want to avoid doing this to allow tcl::kitpath calls 1128 * XXX: to obtain changes in nameofexe, if they occur. 1129 */ 1130 set_rubytk_kitpath(Tcl_GetNameOfExecutable()); 1131 } 1132 1133 return Tcl_PkgProvide(interp, "rubytk_kitpath", "1.0"); 1134} 1135 1136/*--------------------------------------------------------*/ 1137 1138static void 1139init_static_tcltk_packages() 1140{ 1141 /* 1142 * Ensure that std channels exist (creating them if necessary) 1143 */ 1144 check_tclkit_std_channels(); 1145 1146#ifdef KIT_INCLUDES_ITCL 1147 Tcl_StaticPackage(0, "Itcl", Itcl_Init, NULL); 1148#endif 1149#ifdef KIT_LITE 1150 Tcl_StaticPackage(0, "Vlerq", Vlerq_Init, Vlerq_SafeInit); 1151#else 1152 Tcl_StaticPackage(0, "Mk4tcl", Mk4tcl_Init, NULL); 1153#endif 1154#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION < 85 1155 Tcl_StaticPackage(0, "pwb", Pwb_Init, NULL); 1156#endif 1157 Tcl_StaticPackage(0, "rubytk_kitpath", rubytk_kitpath_init, NULL); 1158 Tcl_StaticPackage(0, "rechan", Rechan_Init, NULL); 1159 Tcl_StaticPackage(0, "vfs", Vfs_Init, NULL); 1160#if KIT_INCLUDES_ZLIB 1161 Tcl_StaticPackage(0, "zlib", Zlib_Init, NULL); 1162#endif 1163#if defined TCL_THREADS && defined KIT_INCLUDES_THREAD 1164 Tcl_StaticPackage(0, "Thread", Thread_Init, Thread_SafeInit); 1165#endif 1166#ifdef _WIN32 1167#if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84 1168 Tcl_StaticPackage(0, "dde", Dde_Init, Dde_SafeInit); 1169#else 1170 Tcl_StaticPackage(0, "dde", Dde_Init, NULL); 1171#endif 1172 Tcl_StaticPackage(0, "registry", Registry_Init, NULL); 1173#endif 1174#ifdef KIT_INCLUDES_TK 1175 Tcl_StaticPackage(0, "Tk", Tk_Init, Tk_SafeInit); 1176#endif 1177} 1178 1179/*--------------------------------------------------------*/ 1180 1181static int 1182call_tclkit_init_script(Tcl_Interp *interp) 1183{ 1184#if 0 1185 /* Currently, do nothing in this function. 1186 It's a memo (quoted from kitInit.c of Tclkit) 1187 to support an initScript for Tcl interpreters in the future. */ 1188 if (Tcl_EvalEx(interp, initScript, -1, TCL_EVAL_GLOBAL) == TCL_OK) { 1189 const char *encoding = NULL; 1190 Tcl_Obj* path = Tcl_GetStartupScript(&encoding); 1191 Tcl_SetStartupScript(Tcl_GetObjResult(interp), encoding); 1192 if (path == NULL) { 1193 Tcl_Eval(interp, "incr argc -1; set argv [lrange $argv 1 end]"); 1194 } 1195 } 1196#endif 1197 1198 return 1; 1199} 1200 1201/*--------------------------------------------------------*/ 1202 1203#ifdef __WIN32__ 1204/* #include <tkWinInt.h> *//* conflict definition of struct timezone */ 1205/* #include <tkIntPlatDecls.h> */ 1206/* #include <windows.h> */ 1207EXTERN void TkWinSetHINSTANCE(HINSTANCE hInstance); 1208void rbtk_win32_SetHINSTANCE(const char *module_name) 1209{ 1210 /* TCHAR szBuf[256]; */ 1211 HINSTANCE hInst; 1212 1213 /* hInst = GetModuleHandle(NULL); */ 1214 /* hInst = GetModuleHandle("tcltklib.so"); */ 1215 hInst = GetModuleHandle(module_name); 1216 TkWinSetHINSTANCE(hInst); 1217 1218 /* GetModuleFileName(hInst, szBuf, sizeof(szBuf) / sizeof(TCHAR)); */ 1219 /* MessageBox(NULL, szBuf, TEXT("OK"), MB_OK); */ 1220} 1221#endif 1222 1223/*--------------------------------------------------------*/ 1224 1225static void 1226setup_rubytkkit() 1227{ 1228 init_static_tcltk_packages(); 1229 1230 { 1231 ID const_id; 1232 const_id = rb_intern(RUBYTK_KITPATH_CONST_NAME); 1233 1234 if (rb_const_defined(rb_cObject, const_id)) { 1235 volatile VALUE pathobj; 1236 pathobj = rb_const_get(rb_cObject, const_id); 1237 1238 if (rb_obj_is_kind_of(pathobj, rb_cString)) { 1239#ifdef HAVE_RUBY_ENCODING_H 1240 pathobj = rb_str_export_to_enc(pathobj, rb_utf8_encoding()); 1241#endif 1242 set_rubytk_kitpath(RSTRING_PTR(pathobj)); 1243 } 1244 } 1245 } 1246 1247#ifdef CREATE_RUBYTK_KIT 1248 if (rubytk_kitpath == NULL) { 1249#ifdef __WIN32__ 1250 /* rbtk_win32_SetHINSTANCE("tcltklib.so"); */ 1251 { 1252 volatile VALUE basename; 1253 basename = rb_funcall(rb_cFile, rb_intern("basename"), 1, 1254 rb_str_new2(rb_sourcefile())); 1255 rbtk_win32_SetHINSTANCE(RSTRING_PTR(basename)); 1256 } 1257#endif 1258 set_rubytk_kitpath(rb_sourcefile()); 1259 } 1260#endif 1261 1262 if (rubytk_kitpath == NULL) { 1263 set_rubytk_kitpath(Tcl_GetNameOfExecutable()); 1264 } 1265 1266 TclSetPreInitScript(rubytkkit_preInitCmd); 1267} 1268 1269/*--------------------------------------------------------*/ 1270 1271#endif /* defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT */ 1272/*####################################################################*/ 1273 1274 1275/**********************************************************************/ 1276 1277/* stub status */ 1278static void 1279tcl_stubs_check() 1280{ 1281 if (!tcl_stubs_init_p()) { 1282 int st = ruby_tcl_stubs_init(); 1283 switch(st) { 1284 case TCLTK_STUBS_OK: 1285 break; 1286 case NO_TCL_DLL: 1287 rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll"); 1288 case NO_FindExecutable: 1289 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable"); 1290 case NO_CreateInterp: 1291 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_CreateInterp()"); 1292 case NO_DeleteInterp: 1293 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_DeleteInterp()"); 1294 case FAIL_CreateInterp: 1295 rb_raise(rb_eRuntimeError, "tcltklib: fail to create a new IP to call Tcl_InitStubs()"); 1296 case FAIL_Tcl_InitStubs: 1297 rb_raise(rb_eRuntimeError, "tcltklib: fail to Tcl_InitStubs()"); 1298 default: 1299 rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tcl_stubs_init()", st); 1300 } 1301 } 1302} 1303 1304 1305static VALUE 1306tcltkip_init_tk(interp) 1307 VALUE interp; 1308{ 1309 struct tcltkip *ptr = get_ip(interp); 1310 1311#if TCL_MAJOR_VERSION >= 8 1312 int st; 1313 1314 if (Tcl_IsSafe(ptr->ip)) { 1315 DUMP1("Tk_SafeInit"); 1316 st = ruby_tk_stubs_safeinit(ptr->ip); 1317 switch(st) { 1318 case TCLTK_STUBS_OK: 1319 break; 1320 case NO_Tk_Init: 1321 return rb_exc_new2(rb_eLoadError, 1322 "tcltklib: can't find Tk_SafeInit()"); 1323 case FAIL_Tk_Init: 1324 return create_ip_exc(interp, rb_eRuntimeError, 1325 "tcltklib: fail to Tk_SafeInit(). %s", 1326 Tcl_GetStringResult(ptr->ip)); 1327 case FAIL_Tk_InitStubs: 1328 return create_ip_exc(interp, rb_eRuntimeError, 1329 "tcltklib: fail to Tk_InitStubs(). %s", 1330 Tcl_GetStringResult(ptr->ip)); 1331 default: 1332 return create_ip_exc(interp, rb_eRuntimeError, 1333 "tcltklib: unknown error(%d) on ruby_tk_stubs_safeinit", st); 1334 } 1335 } else { 1336 DUMP1("Tk_Init"); 1337 st = ruby_tk_stubs_init(ptr->ip); 1338 switch(st) { 1339 case TCLTK_STUBS_OK: 1340 break; 1341 case NO_Tk_Init: 1342 return rb_exc_new2(rb_eLoadError, 1343 "tcltklib: can't find Tk_Init()"); 1344 case FAIL_Tk_Init: 1345 return create_ip_exc(interp, rb_eRuntimeError, 1346 "tcltklib: fail to Tk_Init(). %s", 1347 Tcl_GetStringResult(ptr->ip)); 1348 case FAIL_Tk_InitStubs: 1349 return create_ip_exc(interp, rb_eRuntimeError, 1350 "tcltklib: fail to Tk_InitStubs(). %s", 1351 Tcl_GetStringResult(ptr->ip)); 1352 default: 1353 return create_ip_exc(interp, rb_eRuntimeError, 1354 "tcltklib: unknown error(%d) on ruby_tk_stubs_init", st); 1355 } 1356 } 1357 1358#else /* TCL_MAJOR_VERSION < 8 */ 1359 DUMP1("Tk_Init"); 1360 if (ruby_tk_stubs_init(ptr->ip) != TCLTK_STUBS_OK) { 1361 return rb_exc_new2(rb_eRuntimeError, ptr->ip->result); 1362 } 1363#endif 1364 1365#ifdef RUBY_USE_NATIVE_THREAD 1366 ptr->tk_thread_id = Tcl_GetCurrentThread(); 1367#endif 1368 1369 return Qnil; 1370} 1371 1372 1373/* treat excetiopn on Tcl side */ 1374static VALUE rbtk_pending_exception; 1375static int rbtk_eventloop_depth = 0; 1376static int rbtk_internal_eventloop_handler = 0; 1377 1378 1379static int 1380pending_exception_check0() 1381{ 1382 volatile VALUE exc = rbtk_pending_exception; 1383 1384 if (!NIL_P(exc) && rb_obj_is_kind_of(exc, rb_eException)) { 1385 DUMP1("find a pending exception"); 1386 if (rbtk_eventloop_depth > 0 1387 || rbtk_internal_eventloop_handler > 0 1388 ) { 1389 return 1; /* pending */ 1390 } else { 1391 rbtk_pending_exception = Qnil; 1392 1393 if (rb_obj_is_kind_of(exc, eTkCallbackRetry)) { 1394 DUMP1("pending_exception_check0: call rb_jump_tag(retry)"); 1395 rb_jump_tag(TAG_RETRY); 1396 } else if (rb_obj_is_kind_of(exc, eTkCallbackRedo)) { 1397 DUMP1("pending_exception_check0: call rb_jump_tag(redo)"); 1398 rb_jump_tag(TAG_REDO); 1399 } else if (rb_obj_is_kind_of(exc, eTkCallbackThrow)) { 1400 DUMP1("pending_exception_check0: call rb_jump_tag(throw)"); 1401 rb_jump_tag(TAG_THROW); 1402 } 1403 1404 rb_exc_raise(exc); 1405 } 1406 } else { 1407 return 0; 1408 } 1409 1410 UNREACHABLE; 1411} 1412 1413static int 1414pending_exception_check1(thr_crit_bup, ptr) 1415 int thr_crit_bup; 1416 struct tcltkip *ptr; 1417{ 1418 volatile VALUE exc = rbtk_pending_exception; 1419 1420 if (!NIL_P(exc) && rb_obj_is_kind_of(exc, rb_eException)) { 1421 DUMP1("find a pending exception"); 1422 1423 if (rbtk_eventloop_depth > 0 1424 || rbtk_internal_eventloop_handler > 0 1425 ) { 1426 return 1; /* pending */ 1427 } else { 1428 rbtk_pending_exception = Qnil; 1429 1430 if (ptr != (struct tcltkip *)NULL) { 1431 /* Tcl_Release(ptr->ip); */ 1432 rbtk_release_ip(ptr); 1433 } 1434 1435 rb_thread_critical = thr_crit_bup; 1436 1437 if (rb_obj_is_kind_of(exc, eTkCallbackRetry)) { 1438 DUMP1("pending_exception_check1: call rb_jump_tag(retry)"); 1439 rb_jump_tag(TAG_RETRY); 1440 } else if (rb_obj_is_kind_of(exc, eTkCallbackRedo)) { 1441 DUMP1("pending_exception_check1: call rb_jump_tag(redo)"); 1442 rb_jump_tag(TAG_REDO); 1443 } else if (rb_obj_is_kind_of(exc, eTkCallbackThrow)) { 1444 DUMP1("pending_exception_check1: call rb_jump_tag(throw)"); 1445 rb_jump_tag(TAG_THROW); 1446 } 1447 rb_exc_raise(exc); 1448 } 1449 } else { 1450 return 0; 1451 } 1452 1453 UNREACHABLE; 1454} 1455 1456 1457/* call original 'exit' command */ 1458static void 1459call_original_exit(ptr, state) 1460 struct tcltkip *ptr; 1461 int state; 1462{ 1463 int thr_crit_bup; 1464 Tcl_CmdInfo *info; 1465#if TCL_MAJOR_VERSION >= 8 1466 Tcl_Obj *cmd_obj; 1467 Tcl_Obj *state_obj; 1468#endif 1469 DUMP1("original_exit is called"); 1470 1471 if (!(ptr->has_orig_exit)) return; 1472 1473 thr_crit_bup = rb_thread_critical; 1474 rb_thread_critical = Qtrue; 1475 1476 Tcl_ResetResult(ptr->ip); 1477 1478 info = &(ptr->orig_exit_info); 1479 1480 /* memory allocation for arguments of this command */ 1481#if TCL_MAJOR_VERSION >= 8 1482 state_obj = Tcl_NewIntObj(state); 1483 Tcl_IncrRefCount(state_obj); 1484 1485 if (info->isNativeObjectProc) { 1486 Tcl_Obj **argv; 1487#define USE_RUBY_ALLOC 0 1488#if USE_RUBY_ALLOC 1489 argv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, 3); 1490#else /* not USE_RUBY_ALLOC */ 1491 argv = RbTk_ALLOC_N(Tcl_Obj *, 3); 1492#if 0 /* use Tcl_Preserve/Release */ 1493 Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ 1494#endif 1495#endif 1496 cmd_obj = Tcl_NewStringObj("exit", 4); 1497 Tcl_IncrRefCount(cmd_obj); 1498 1499 argv[0] = cmd_obj; 1500 argv[1] = state_obj; 1501 argv[2] = (Tcl_Obj *)NULL; 1502 1503 ptr->return_value 1504 = (*(info->objProc))(info->objClientData, ptr->ip, 2, argv); 1505 1506 Tcl_DecrRefCount(cmd_obj); 1507 1508#if USE_RUBY_ALLOC 1509 xfree(argv); 1510#else /* not USE_RUBY_ALLOC */ 1511#if 0 /* use Tcl_EventuallyFree */ 1512 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ 1513#else 1514#if 0 /* use Tcl_Preserve/Release */ 1515 Tcl_Release((ClientData)argv); /* XXXXXXXX */ 1516#else 1517 /* free(argv); */ 1518 ckfree((char*)argv); 1519#endif 1520#endif 1521#endif 1522#undef USE_RUBY_ALLOC 1523 1524 } else { 1525 /* string interface */ 1526 CONST84 char **argv; 1527#define USE_RUBY_ALLOC 0 1528#if USE_RUBY_ALLOC 1529 argv = ALLOC_N(char *, 3); /* XXXXXXXXXX */ 1530#else /* not USE_RUBY_ALLOC */ 1531 argv = RbTk_ALLOC_N(CONST84 char *, 3); 1532#if 0 /* use Tcl_Preserve/Release */ 1533 Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ 1534#endif 1535#endif 1536 argv[0] = (char *)"exit"; 1537 /* argv[1] = Tcl_GetString(state_obj); */ 1538 argv[1] = Tcl_GetStringFromObj(state_obj, (int*)NULL); 1539 argv[2] = (char *)NULL; 1540 1541 ptr->return_value = (*(info->proc))(info->clientData, ptr->ip, 2, argv); 1542 1543#if USE_RUBY_ALLOC 1544 xfree(argv); 1545#else /* not USE_RUBY_ALLOC */ 1546#if 0 /* use Tcl_EventuallyFree */ 1547 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ 1548#else 1549#if 0 /* use Tcl_Preserve/Release */ 1550 Tcl_Release((ClientData)argv); /* XXXXXXXX */ 1551#else 1552 /* free(argv); */ 1553 ckfree((char*)argv); 1554#endif 1555#endif 1556#endif 1557#undef USE_RUBY_ALLOC 1558 } 1559 1560 Tcl_DecrRefCount(state_obj); 1561 1562#else /* TCL_MAJOR_VERSION < 8 */ 1563 { 1564 /* string interface */ 1565 char **argv; 1566#define USE_RUBY_ALLOC 0 1567#if USE_RUBY_ALLOC 1568 argv = (char **)ALLOC_N(char *, 3); 1569#else /* not USE_RUBY_ALLOC */ 1570 argv = RbTk_ALLOC_N(char *, 3); 1571#if 0 /* use Tcl_Preserve/Release */ 1572 Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ 1573#endif 1574#endif 1575 argv[0] = "exit"; 1576 argv[1] = RSTRING_PTR(rb_fix2str(INT2NUM(state), 10)); 1577 argv[2] = (char *)NULL; 1578 1579 ptr->return_value = (*(info->proc))(info->clientData, ptr->ip, 1580 2, argv); 1581 1582#if USE_RUBY_ALLOC 1583 xfree(argv); 1584#else /* not USE_RUBY_ALLOC */ 1585#if 0 /* use Tcl_EventuallyFree */ 1586 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ 1587#else 1588#if 0 /* use Tcl_Preserve/Release */ 1589 Tcl_Release((ClientData)argv); /* XXXXXXXX */ 1590#else 1591 /* free(argv); */ 1592 ckfree(argv); 1593#endif 1594#endif 1595#endif 1596#undef USE_RUBY_ALLOC 1597 } 1598#endif 1599 DUMP1("complete original_exit"); 1600 1601 rb_thread_critical = thr_crit_bup; 1602} 1603 1604/* Tk_ThreadTimer */ 1605static Tcl_TimerToken timer_token = (Tcl_TimerToken)NULL; 1606 1607/* timer callback */ 1608static void _timer_for_tcl _((ClientData)); 1609static void 1610_timer_for_tcl(clientData) 1611 ClientData clientData; 1612{ 1613 int thr_crit_bup; 1614 1615 /* struct invoke_queue *q, *tmp; */ 1616 /* VALUE thread; */ 1617 1618 DUMP1("call _timer_for_tcl"); 1619 1620 thr_crit_bup = rb_thread_critical; 1621 rb_thread_critical = Qtrue; 1622 1623 Tcl_DeleteTimerHandler(timer_token); 1624 1625 run_timer_flag = 1; 1626 1627 if (timer_tick > 0) { 1628 timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl, 1629 (ClientData)0); 1630 } else { 1631 timer_token = (Tcl_TimerToken)NULL; 1632 } 1633 1634 rb_thread_critical = thr_crit_bup; 1635 1636 /* rb_thread_schedule(); */ 1637 /* tick_counter += event_loop_max; */ 1638} 1639 1640#ifdef RUBY_USE_NATIVE_THREAD 1641#if USE_TOGGLE_WINDOW_MODE_FOR_IDLE 1642static int 1643toggle_eventloop_window_mode_for_idle() 1644{ 1645 if (window_event_mode & TCL_IDLE_EVENTS) { 1646 /* idle -> event */ 1647 window_event_mode |= TCL_WINDOW_EVENTS; 1648 window_event_mode &= ~TCL_IDLE_EVENTS; 1649 return 1; 1650 } else { 1651 /* event -> idle */ 1652 window_event_mode |= TCL_IDLE_EVENTS; 1653 window_event_mode &= ~TCL_WINDOW_EVENTS; 1654 return 0; 1655 } 1656} 1657#endif 1658#endif 1659 1660static VALUE 1661set_eventloop_window_mode(self, mode) 1662 VALUE self; 1663 VALUE mode; 1664{ 1665 rb_secure(4); 1666 1667 if (RTEST(mode)) { 1668 window_event_mode = ~0; 1669 } else { 1670 window_event_mode = ~TCL_WINDOW_EVENTS; 1671 } 1672 1673 return mode; 1674} 1675 1676static VALUE 1677get_eventloop_window_mode(self) 1678 VALUE self; 1679{ 1680 if ( ~window_event_mode ) { 1681 return Qfalse; 1682 } else { 1683 return Qtrue; 1684 } 1685} 1686 1687static VALUE 1688set_eventloop_tick(self, tick) 1689 VALUE self; 1690 VALUE tick; 1691{ 1692 int ttick = NUM2INT(tick); 1693 int thr_crit_bup; 1694 1695 rb_secure(4); 1696 1697 if (ttick < 0) { 1698 rb_raise(rb_eArgError, 1699 "timer-tick parameter must be 0 or positive number"); 1700 } 1701 1702 thr_crit_bup = rb_thread_critical; 1703 rb_thread_critical = Qtrue; 1704 1705 /* delete old timer callback */ 1706 Tcl_DeleteTimerHandler(timer_token); 1707 1708 timer_tick = req_timer_tick = ttick; 1709 if (timer_tick > 0) { 1710 /* start timer callback */ 1711 timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl, 1712 (ClientData)0); 1713 } else { 1714 timer_token = (Tcl_TimerToken)NULL; 1715 } 1716 1717 rb_thread_critical = thr_crit_bup; 1718 1719 return tick; 1720} 1721 1722static VALUE 1723get_eventloop_tick(self) 1724 VALUE self; 1725{ 1726 return INT2NUM(timer_tick); 1727} 1728 1729static VALUE 1730ip_set_eventloop_tick(self, tick) 1731 VALUE self; 1732 VALUE tick; 1733{ 1734 struct tcltkip *ptr = get_ip(self); 1735 1736 /* ip is deleted? */ 1737 if (deleted_ip(ptr)) { 1738 return get_eventloop_tick(self); 1739 } 1740 1741 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { 1742 /* slave IP */ 1743 return get_eventloop_tick(self); 1744 } 1745 return set_eventloop_tick(self, tick); 1746} 1747 1748static VALUE 1749ip_get_eventloop_tick(self) 1750 VALUE self; 1751{ 1752 return get_eventloop_tick(self); 1753} 1754 1755static VALUE 1756set_no_event_wait(self, wait) 1757 VALUE self; 1758 VALUE wait; 1759{ 1760 int t_wait = NUM2INT(wait); 1761 1762 rb_secure(4); 1763 1764 if (t_wait <= 0) { 1765 rb_raise(rb_eArgError, 1766 "no_event_wait parameter must be positive number"); 1767 } 1768 1769 no_event_wait = t_wait; 1770 1771 return wait; 1772} 1773 1774static VALUE 1775get_no_event_wait(self) 1776 VALUE self; 1777{ 1778 return INT2NUM(no_event_wait); 1779} 1780 1781static VALUE 1782ip_set_no_event_wait(self, wait) 1783 VALUE self; 1784 VALUE wait; 1785{ 1786 struct tcltkip *ptr = get_ip(self); 1787 1788 /* ip is deleted? */ 1789 if (deleted_ip(ptr)) { 1790 return get_no_event_wait(self); 1791 } 1792 1793 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { 1794 /* slave IP */ 1795 return get_no_event_wait(self); 1796 } 1797 return set_no_event_wait(self, wait); 1798} 1799 1800static VALUE 1801ip_get_no_event_wait(self) 1802 VALUE self; 1803{ 1804 return get_no_event_wait(self); 1805} 1806 1807static VALUE 1808set_eventloop_weight(self, loop_max, no_event) 1809 VALUE self; 1810 VALUE loop_max; 1811 VALUE no_event; 1812{ 1813 int lpmax = NUM2INT(loop_max); 1814 int no_ev = NUM2INT(no_event); 1815 1816 rb_secure(4); 1817 1818 if (lpmax <= 0 || no_ev <= 0) { 1819 rb_raise(rb_eArgError, "weight parameters must be positive numbers"); 1820 } 1821 1822 event_loop_max = lpmax; 1823 no_event_tick = no_ev; 1824 1825 return rb_ary_new3(2, loop_max, no_event); 1826} 1827 1828static VALUE 1829get_eventloop_weight(self) 1830 VALUE self; 1831{ 1832 return rb_ary_new3(2, INT2NUM(event_loop_max), INT2NUM(no_event_tick)); 1833} 1834 1835static VALUE 1836ip_set_eventloop_weight(self, loop_max, no_event) 1837 VALUE self; 1838 VALUE loop_max; 1839 VALUE no_event; 1840{ 1841 struct tcltkip *ptr = get_ip(self); 1842 1843 /* ip is deleted? */ 1844 if (deleted_ip(ptr)) { 1845 return get_eventloop_weight(self); 1846 } 1847 1848 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { 1849 /* slave IP */ 1850 return get_eventloop_weight(self); 1851 } 1852 return set_eventloop_weight(self, loop_max, no_event); 1853} 1854 1855static VALUE 1856ip_get_eventloop_weight(self) 1857 VALUE self; 1858{ 1859 return get_eventloop_weight(self); 1860} 1861 1862static VALUE 1863set_max_block_time(self, time) 1864 VALUE self; 1865 VALUE time; 1866{ 1867 struct Tcl_Time tcl_time; 1868 VALUE divmod; 1869 1870 switch(TYPE(time)) { 1871 case T_FIXNUM: 1872 case T_BIGNUM: 1873 /* time is micro-second value */ 1874 divmod = rb_funcall(time, rb_intern("divmod"), 1, LONG2NUM(1000000)); 1875 tcl_time.sec = NUM2LONG(RARRAY_PTR(divmod)[0]); 1876 tcl_time.usec = NUM2LONG(RARRAY_PTR(divmod)[1]); 1877 break; 1878 1879 case T_FLOAT: 1880 /* time is second value */ 1881 divmod = rb_funcall(time, rb_intern("divmod"), 1, INT2FIX(1)); 1882 tcl_time.sec = NUM2LONG(RARRAY_PTR(divmod)[0]); 1883 tcl_time.usec = (long)(NUM2DBL(RARRAY_PTR(divmod)[1]) * 1000000); 1884 1885 default: 1886 { 1887 VALUE tmp = rb_funcall(time, ID_inspect, 0, 0); 1888 rb_raise(rb_eArgError, "invalid value for time: '%s'", 1889 StringValuePtr(tmp)); 1890 } 1891 } 1892 1893 Tcl_SetMaxBlockTime(&tcl_time); 1894 1895 return Qnil; 1896} 1897 1898static VALUE 1899lib_evloop_thread_p(self) 1900 VALUE self; 1901{ 1902 if (NIL_P(eventloop_thread)) { 1903 return Qnil; /* no eventloop */ 1904 } else if (rb_thread_current() == eventloop_thread) { 1905 return Qtrue; /* is eventloop */ 1906 } else { 1907 return Qfalse; /* not eventloop */ 1908 } 1909} 1910 1911static VALUE 1912lib_evloop_abort_on_exc(self) 1913 VALUE self; 1914{ 1915 if (event_loop_abort_on_exc > 0) { 1916 return Qtrue; 1917 } else if (event_loop_abort_on_exc == 0) { 1918 return Qfalse; 1919 } else { 1920 return Qnil; 1921 } 1922} 1923 1924static VALUE 1925ip_evloop_abort_on_exc(self) 1926 VALUE self; 1927{ 1928 return lib_evloop_abort_on_exc(self); 1929} 1930 1931static VALUE 1932lib_evloop_abort_on_exc_set(self, val) 1933 VALUE self, val; 1934{ 1935 rb_secure(4); 1936 if (RTEST(val)) { 1937 event_loop_abort_on_exc = 1; 1938 } else if (NIL_P(val)) { 1939 event_loop_abort_on_exc = -1; 1940 } else { 1941 event_loop_abort_on_exc = 0; 1942 } 1943 return lib_evloop_abort_on_exc(self); 1944} 1945 1946static VALUE 1947ip_evloop_abort_on_exc_set(self, val) 1948 VALUE self, val; 1949{ 1950 struct tcltkip *ptr = get_ip(self); 1951 1952 rb_secure(4); 1953 1954 /* ip is deleted? */ 1955 if (deleted_ip(ptr)) { 1956 return lib_evloop_abort_on_exc(self); 1957 } 1958 1959 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { 1960 /* slave IP */ 1961 return lib_evloop_abort_on_exc(self); 1962 } 1963 return lib_evloop_abort_on_exc_set(self, val); 1964} 1965 1966static VALUE 1967lib_num_of_mainwindows_core(self, argc, argv) 1968 VALUE self; 1969 int argc; /* dummy */ 1970 VALUE *argv; /* dummy */ 1971{ 1972 if (tk_stubs_init_p()) { 1973 return INT2FIX(Tk_GetNumMainWindows()); 1974 } else { 1975 return INT2FIX(0); 1976 } 1977} 1978 1979static VALUE 1980lib_num_of_mainwindows(self) 1981 VALUE self; 1982{ 1983#ifdef RUBY_USE_NATIVE_THREAD /* Ruby 1.9+ !!! */ 1984 return tk_funcall(lib_num_of_mainwindows_core, 0, (VALUE*)NULL, self); 1985#else 1986 return lib_num_of_mainwindows_core(self, 0, (VALUE*)NULL); 1987#endif 1988} 1989 1990void 1991rbtk_EventSetupProc(ClientData clientData, int flag) 1992{ 1993 Tcl_Time tcl_time; 1994 tcl_time.sec = 0; 1995 tcl_time.usec = 1000L * (long)no_event_tick; 1996 Tcl_SetMaxBlockTime(&tcl_time); 1997} 1998 1999void 2000rbtk_EventCheckProc(ClientData clientData, int flag) 2001{ 2002 rb_thread_schedule(); 2003} 2004 2005 2006#ifdef RUBY_USE_NATIVE_THREAD /* Ruby 1.9+ !!! */ 2007static VALUE 2008#ifdef HAVE_PROTOTYPES 2009call_DoOneEvent_core(VALUE flag_val) 2010#else 2011call_DoOneEvent_core(flag_val) 2012 VALUE flag_val; 2013#endif 2014{ 2015 int flag; 2016 2017 flag = FIX2INT(flag_val); 2018 if (Tcl_DoOneEvent(flag)) { 2019 return Qtrue; 2020 } else { 2021 return Qfalse; 2022 } 2023} 2024 2025static VALUE 2026#ifdef HAVE_PROTOTYPES 2027call_DoOneEvent(VALUE flag_val) 2028#else 2029call_DoOneEvent(flag_val) 2030 VALUE flag_val; 2031#endif 2032{ 2033 return tk_funcall(call_DoOneEvent_core, 0, (VALUE*)NULL, flag_val); 2034} 2035 2036#else /* Ruby 1.8- */ 2037static VALUE 2038#ifdef HAVE_PROTOTYPES 2039call_DoOneEvent(VALUE flag_val) 2040#else 2041call_DoOneEvent(flag_val) 2042 VALUE flag_val; 2043#endif 2044{ 2045 int flag; 2046 2047 flag = FIX2INT(flag_val); 2048 if (Tcl_DoOneEvent(flag)) { 2049 return Qtrue; 2050 } else { 2051 return Qfalse; 2052 } 2053} 2054#endif 2055 2056 2057#if 0 2058static VALUE 2059#ifdef HAVE_PROTOTYPES 2060eventloop_sleep(VALUE dummy) 2061#else 2062eventloop_sleep(dummy) 2063 VALUE dummy; 2064#endif 2065{ 2066 struct timeval t; 2067 2068 if (no_event_wait <= 0) { 2069 return Qnil; 2070 } 2071 2072 t.tv_sec = 0; 2073 t.tv_usec = (int)(no_event_wait*1000.0); 2074 2075#ifdef HAVE_NATIVETHREAD 2076#ifndef RUBY_USE_NATIVE_THREAD 2077 if (!ruby_native_thread_p()) { 2078 rb_bug("cross-thread violation on eventloop_sleep()"); 2079 } 2080#endif 2081#endif 2082 2083 DUMP2("eventloop_sleep: rb_thread_wait_for() at thread : %lx", rb_thread_current()); 2084 rb_thread_wait_for(t); 2085 DUMP2("eventloop_sleep: finish at thread : %lx", rb_thread_current()); 2086 2087#ifdef HAVE_NATIVETHREAD 2088#ifndef RUBY_USE_NATIVE_THREAD 2089 if (!ruby_native_thread_p()) { 2090 rb_bug("cross-thread violation on eventloop_sleep()"); 2091 } 2092#endif 2093#endif 2094 2095 return Qnil; 2096} 2097#endif 2098 2099#define USE_EVLOOP_THREAD_ALONE_CHECK_FLAG 0 2100 2101#if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG 2102static int 2103get_thread_alone_check_flag() 2104{ 2105#ifdef RUBY_USE_NATIVE_THREAD 2106 return 0; 2107#else 2108 set_tcltk_version(); 2109 2110 if (tcltk_version.major < 8) { 2111 /* Tcl/Tk 7.x */ 2112 return 1; 2113 } else if (tcltk_version.major == 8) { 2114 if (tcltk_version.minor < 5) { 2115 /* Tcl/Tk 8.0 - 8.4 */ 2116 return 1; 2117 } else if (tcltk_version.minor == 5) { 2118 if (tcltk_version.type < TCL_FINAL_RELEASE) { 2119 /* Tcl/Tk 8.5a? - 8.5b? */ 2120 return 1; 2121 } else { 2122 /* Tcl/Tk 8.5.x */ 2123 return 0; 2124 } 2125 } else { 2126 /* Tcl/Tk 8.6 - 8.9 ?? */ 2127 return 0; 2128 } 2129 } else { 2130 /* Tcl/Tk 9+ ?? */ 2131 return 0; 2132 } 2133#endif 2134} 2135#endif 2136 2137#define TRAP_CHECK() do { \ 2138 if (trap_check(check_var) == 0) return 0; \ 2139} while (0) 2140 2141static int 2142trap_check(int *check_var) 2143{ 2144 DUMP1("trap check"); 2145 2146#ifdef RUBY_VM 2147 if (rb_thread_check_trap_pending()) { 2148 if (check_var != (int*)NULL) { 2149 /* wait command */ 2150 return 0; 2151 } 2152 else { 2153 rb_thread_check_ints(); 2154 } 2155 } 2156#else 2157 if (rb_trap_pending) { 2158 run_timer_flag = 0; 2159 if (rb_prohibit_interrupt || check_var != (int*)NULL) { 2160 /* pending or on wait command */ 2161 return 0; 2162 } else { 2163 rb_trap_exec(); 2164 } 2165 } 2166#endif 2167 2168 return 1; 2169} 2170 2171static int 2172check_eventloop_interp() 2173{ 2174 DUMP1("check eventloop_interp"); 2175 if (eventloop_interp != (Tcl_Interp*)NULL 2176 && Tcl_InterpDeleted(eventloop_interp)) { 2177 DUMP2("eventloop_interp(%p) was deleted", eventloop_interp); 2178 return 1; 2179 } 2180 2181 return 0; 2182} 2183 2184static int 2185lib_eventloop_core(check_root, update_flag, check_var, interp) 2186 int check_root; 2187 int update_flag; 2188 int *check_var; 2189 Tcl_Interp *interp; 2190{ 2191 volatile VALUE current = eventloop_thread; 2192 int found_event = 1; 2193 int event_flag; 2194 struct timeval t; 2195 int thr_crit_bup; 2196 int status; 2197 int depth = rbtk_eventloop_depth; 2198#if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG 2199 int thread_alone_check_flag = 1; 2200#endif 2201 2202 if (update_flag) DUMP1("update loop start!!"); 2203 2204 t.tv_sec = 0; 2205 t.tv_usec = 1000 * no_event_wait; 2206 2207 Tcl_DeleteTimerHandler(timer_token); 2208 run_timer_flag = 0; 2209 if (timer_tick > 0) { 2210 thr_crit_bup = rb_thread_critical; 2211 rb_thread_critical = Qtrue; 2212 timer_token = Tcl_CreateTimerHandler(timer_tick, _timer_for_tcl, 2213 (ClientData)0); 2214 rb_thread_critical = thr_crit_bup; 2215 } else { 2216 timer_token = (Tcl_TimerToken)NULL; 2217 } 2218 2219#if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG 2220 /* version check */ 2221 thread_alone_check_flag = get_thread_alone_check_flag(); 2222#endif 2223 2224 for(;;) { 2225 if (check_eventloop_interp()) return 0; 2226 2227#if USE_EVLOOP_THREAD_ALONE_CHECK_FLAG 2228 if (thread_alone_check_flag && rb_thread_alone()) { 2229#else 2230 if (rb_thread_alone()) { 2231#endif 2232 DUMP1("no other thread"); 2233 event_loop_wait_event = 0; 2234 2235 if (update_flag) { 2236 event_flag = update_flag; 2237 /* event_flag = update_flag | TCL_DONT_WAIT; */ /* for safety */ 2238 } else { 2239 event_flag = TCL_ALL_EVENTS; 2240 /* event_flag = TCL_ALL_EVENTS | TCL_DONT_WAIT; */ 2241 } 2242 2243 if (timer_tick == 0 && update_flag == 0) { 2244 timer_tick = NO_THREAD_INTERRUPT_TIME; 2245 timer_token = Tcl_CreateTimerHandler(timer_tick, 2246 _timer_for_tcl, 2247 (ClientData)0); 2248 } 2249 2250 if (check_var != (int *)NULL) { 2251 if (*check_var || !found_event) { 2252 return found_event; 2253 } 2254 if (interp != (Tcl_Interp*)NULL 2255 && Tcl_InterpDeleted(interp)) { 2256 /* IP for check_var is deleted */ 2257 return 0; 2258 } 2259 } 2260 2261 /* found_event = Tcl_DoOneEvent(event_flag); */ 2262 found_event = RTEST(rb_protect(call_DoOneEvent, 2263 INT2FIX(event_flag), &status)); 2264 if (status) { 2265 switch (status) { 2266 case TAG_RAISE: 2267 if (NIL_P(rb_errinfo())) { 2268 rbtk_pending_exception 2269 = rb_exc_new2(rb_eException, "unknown exception"); 2270 } else { 2271 rbtk_pending_exception = rb_errinfo(); 2272 2273 if (!NIL_P(rbtk_pending_exception)) { 2274 if (rbtk_eventloop_depth == 0) { 2275 VALUE exc = rbtk_pending_exception; 2276 rbtk_pending_exception = Qnil; 2277 rb_exc_raise(exc); 2278 } else { 2279 return 0; 2280 } 2281 } 2282 } 2283 break; 2284 2285 case TAG_FATAL: 2286 if (NIL_P(rb_errinfo())) { 2287 rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL")); 2288 } else { 2289 rb_exc_raise(rb_errinfo()); 2290 } 2291 } 2292 } 2293 2294 if (depth != rbtk_eventloop_depth) { 2295 DUMP2("DoOneEvent(1) abnormal exit!! %d", 2296 rbtk_eventloop_depth); 2297 } 2298 2299 if (check_var != (int*)NULL && !NIL_P(rbtk_pending_exception)) { 2300 DUMP1("exception on wait"); 2301 return 0; 2302 } 2303 2304 if (pending_exception_check0()) { 2305 /* pending -> upper level */ 2306 return 0; 2307 } 2308 2309 if (update_flag != 0) { 2310 if (found_event) { 2311 DUMP1("next update loop"); 2312 continue; 2313 } else { 2314 DUMP1("update complete"); 2315 return 0; 2316 } 2317 } 2318 2319 TRAP_CHECK(); 2320 if (check_eventloop_interp()) return 0; 2321 2322 DUMP1("check Root Widget"); 2323 if (check_root && tk_stubs_init_p() && Tk_GetNumMainWindows() == 0) { 2324 run_timer_flag = 0; 2325 TRAP_CHECK(); 2326 return 1; 2327 } 2328 2329 if (loop_counter++ > 30000) { 2330 /* fprintf(stderr, "loop_counter > 30000\n"); */ 2331 loop_counter = 0; 2332 } 2333 2334 } else { 2335 int tick_counter; 2336 2337 DUMP1("there are other threads"); 2338 event_loop_wait_event = 1; 2339 2340 found_event = 1; 2341 2342 if (update_flag) { 2343 event_flag = update_flag; /* for safety */ 2344 /* event_flag = update_flag | TCL_DONT_WAIT; */ /* for safety */ 2345 } else { 2346 event_flag = TCL_ALL_EVENTS; 2347 /* event_flag = TCL_ALL_EVENTS | TCL_DONT_WAIT; */ 2348 } 2349 2350 timer_tick = req_timer_tick; 2351 tick_counter = 0; 2352 while(tick_counter < event_loop_max) { 2353 if (check_var != (int *)NULL) { 2354 if (*check_var || !found_event) { 2355 return found_event; 2356 } 2357 if (interp != (Tcl_Interp*)NULL 2358 && Tcl_InterpDeleted(interp)) { 2359 /* IP for check_var is deleted */ 2360 return 0; 2361 } 2362 } 2363 2364 if (NIL_P(eventloop_thread) || current == eventloop_thread) { 2365 int st; 2366 int status; 2367 2368#ifdef RUBY_USE_NATIVE_THREAD 2369 if (update_flag) { 2370 st = RTEST(rb_protect(call_DoOneEvent, 2371 INT2FIX(event_flag), &status)); 2372 } else { 2373 st = RTEST(rb_protect(call_DoOneEvent, 2374 INT2FIX(event_flag & window_event_mode), 2375 &status)); 2376#if USE_TOGGLE_WINDOW_MODE_FOR_IDLE 2377 if (!st) { 2378 if (toggle_eventloop_window_mode_for_idle()) { 2379 /* idle-mode -> event-mode*/ 2380 tick_counter = event_loop_max; 2381 } else { 2382 /* event-mode -> idle-mode */ 2383 tick_counter = 0; 2384 } 2385 } 2386#endif 2387 } 2388#else 2389 /* st = Tcl_DoOneEvent(event_flag); */ 2390 st = RTEST(rb_protect(call_DoOneEvent, 2391 INT2FIX(event_flag), &status)); 2392#endif 2393 2394#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 2395 if (have_rb_thread_waiting_for_value) { 2396 have_rb_thread_waiting_for_value = 0; 2397 rb_thread_schedule(); 2398 } 2399#endif 2400 2401 if (status) { 2402 switch (status) { 2403 case TAG_RAISE: 2404 if (NIL_P(rb_errinfo())) { 2405 rbtk_pending_exception 2406 = rb_exc_new2(rb_eException, 2407 "unknown exception"); 2408 } else { 2409 rbtk_pending_exception = rb_errinfo(); 2410 2411 if (!NIL_P(rbtk_pending_exception)) { 2412 if (rbtk_eventloop_depth == 0) { 2413 VALUE exc = rbtk_pending_exception; 2414 rbtk_pending_exception = Qnil; 2415 rb_exc_raise(exc); 2416 } else { 2417 return 0; 2418 } 2419 } 2420 } 2421 break; 2422 2423 case TAG_FATAL: 2424 if (NIL_P(rb_errinfo())) { 2425 rb_exc_raise(rb_exc_new2(rb_eFatal, "FATAL")); 2426 } else { 2427 rb_exc_raise(rb_errinfo()); 2428 } 2429 } 2430 } 2431 2432 if (depth != rbtk_eventloop_depth) { 2433 DUMP2("DoOneEvent(2) abnormal exit!! %d", 2434 rbtk_eventloop_depth); 2435 return 0; 2436 } 2437 2438 TRAP_CHECK(); 2439 2440 if (check_var != (int*)NULL 2441 && !NIL_P(rbtk_pending_exception)) { 2442 DUMP1("exception on wait"); 2443 return 0; 2444 } 2445 2446 if (pending_exception_check0()) { 2447 /* pending -> upper level */ 2448 return 0; 2449 } 2450 2451 if (st) { 2452 tick_counter++; 2453 } else { 2454 if (update_flag != 0) { 2455 DUMP1("update complete"); 2456 return 0; 2457 } 2458 2459 tick_counter += no_event_tick; 2460 2461#if 0 2462 /* rb_thread_wait_for(t); */ 2463 rb_protect(eventloop_sleep, Qnil, &status); 2464 2465 if (status) { 2466 switch (status) { 2467 case TAG_RAISE: 2468 if (NIL_P(rb_errinfo())) { 2469 rbtk_pending_exception 2470 = rb_exc_new2(rb_eException, 2471 "unknown exception"); 2472 } else { 2473 rbtk_pending_exception = rb_errinfo(); 2474 2475 if (!NIL_P(rbtk_pending_exception)) { 2476 if (rbtk_eventloop_depth == 0) { 2477 VALUE exc = rbtk_pending_exception; 2478 rbtk_pending_exception = Qnil; 2479 rb_exc_raise(exc); 2480 } else { 2481 return 0; 2482 } 2483 } 2484 } 2485 break; 2486 2487 case TAG_FATAL: 2488 if (NIL_P(rb_errinfo())) { 2489 rb_exc_raise(rb_exc_new2(rb_eFatal, 2490 "FATAL")); 2491 } else { 2492 rb_exc_raise(rb_errinfo()); 2493 } 2494 } 2495 } 2496#endif 2497 } 2498 2499 } else { 2500 DUMP2("sleep eventloop %lx", current); 2501 DUMP2("eventloop thread is %lx", eventloop_thread); 2502 /* rb_thread_stop(); */ 2503 rb_thread_sleep_forever(); 2504 } 2505 2506 if (!NIL_P(watchdog_thread) && eventloop_thread != current) { 2507 return 1; 2508 } 2509 2510 TRAP_CHECK(); 2511 if (check_eventloop_interp()) return 0; 2512 2513 DUMP1("check Root Widget"); 2514 if (check_root && tk_stubs_init_p() && Tk_GetNumMainWindows() == 0) { 2515 run_timer_flag = 0; 2516 TRAP_CHECK(); 2517 return 1; 2518 } 2519 2520 if (loop_counter++ > 30000) { 2521 /* fprintf(stderr, "loop_counter > 30000\n"); */ 2522 loop_counter = 0; 2523 } 2524 2525 if (run_timer_flag) { 2526 /* 2527 DUMP1("timer interrupt"); 2528 run_timer_flag = 0; 2529 */ 2530 break; /* switch to other thread */ 2531 } 2532 } 2533 2534 DUMP1("thread scheduling"); 2535 rb_thread_schedule(); 2536 } 2537 2538 DUMP1("check interrupts"); 2539#if defined(RUBY_USE_NATIVE_THREAD) || defined(RUBY_VM) 2540 if (update_flag == 0) rb_thread_check_ints(); 2541#else 2542 if (update_flag == 0) CHECK_INTS; 2543#endif 2544 2545 } 2546 return 1; 2547} 2548 2549 2550struct evloop_params { 2551 int check_root; 2552 int update_flag; 2553 int *check_var; 2554 Tcl_Interp *interp; 2555 int thr_crit_bup; 2556}; 2557 2558VALUE 2559lib_eventloop_main_core(args) 2560 VALUE args; 2561{ 2562 struct evloop_params *params = (struct evloop_params *)args; 2563 2564 check_rootwidget_flag = params->check_root; 2565 2566 Tcl_CreateEventSource(rbtk_EventSetupProc, rbtk_EventCheckProc, (ClientData)args); 2567 2568 if (lib_eventloop_core(params->check_root, 2569 params->update_flag, 2570 params->check_var, 2571 params->interp)) { 2572 return Qtrue; 2573 } else { 2574 return Qfalse; 2575 } 2576} 2577 2578VALUE 2579lib_eventloop_main(args) 2580 VALUE args; 2581{ 2582 return lib_eventloop_main_core(args); 2583 2584#if 0 2585 volatile VALUE ret; 2586 int status = 0; 2587 2588 ret = rb_protect(lib_eventloop_main_core, args, &status); 2589 2590 switch (status) { 2591 case TAG_RAISE: 2592 if (NIL_P(rb_errinfo())) { 2593 rbtk_pending_exception 2594 = rb_exc_new2(rb_eException, "unknown exception"); 2595 } else { 2596 rbtk_pending_exception = rb_errinfo(); 2597 } 2598 return Qnil; 2599 2600 case TAG_FATAL: 2601 if (NIL_P(rb_errinfo())) { 2602 rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL"); 2603 } else { 2604 rbtk_pending_exception = rb_errinfo(); 2605 } 2606 return Qnil; 2607 } 2608 2609 return ret; 2610#endif 2611} 2612 2613VALUE 2614lib_eventloop_ensure(args) 2615 VALUE args; 2616{ 2617 struct evloop_params *ptr = (struct evloop_params *)args; 2618 volatile VALUE current_evloop = rb_thread_current(); 2619 2620 Tcl_DeleteEventSource(rbtk_EventSetupProc, rbtk_EventCheckProc, (ClientData)args); 2621 2622 DUMP2("eventloop_ensure: current-thread : %lx", current_evloop); 2623 DUMP2("eventloop_ensure: eventloop-thread : %lx", eventloop_thread); 2624 if (eventloop_thread != current_evloop) { 2625 DUMP2("finish eventloop %lx (NOT current eventloop)", current_evloop); 2626 2627 rb_thread_critical = ptr->thr_crit_bup; 2628 2629 xfree(ptr); 2630 /* ckfree((char*)ptr); */ 2631 2632 return Qnil; 2633 } 2634 2635 while((eventloop_thread = rb_ary_pop(eventloop_stack))) { 2636 DUMP2("eventloop-ensure: new eventloop-thread -> %lx", 2637 eventloop_thread); 2638 2639 if (eventloop_thread == current_evloop) { 2640 rbtk_eventloop_depth--; 2641 DUMP2("eventloop %lx : back from recursive call", current_evloop); 2642 break; 2643 } 2644 2645 if (NIL_P(eventloop_thread)) { 2646 Tcl_DeleteTimerHandler(timer_token); 2647 timer_token = (Tcl_TimerToken)NULL; 2648 2649 break; 2650 } 2651 2652#ifdef RUBY_VM 2653 if (RTEST(rb_funcall(eventloop_thread, ID_alive_p, 0, 0))) { 2654#else 2655 if (RTEST(rb_thread_alive_p(eventloop_thread))) { 2656#endif 2657 DUMP2("eventloop-enshure: wake up parent %lx", eventloop_thread); 2658 rb_thread_wakeup(eventloop_thread); 2659 2660 break; 2661 } 2662 } 2663 2664#ifdef RUBY_USE_NATIVE_THREAD 2665 if (NIL_P(eventloop_thread)) { 2666 tk_eventloop_thread_id = (Tcl_ThreadId) 0; 2667 } 2668#endif 2669 2670 rb_thread_critical = ptr->thr_crit_bup; 2671 2672 xfree(ptr); 2673 /* ckfree((char*)ptr);*/ 2674 2675 DUMP2("finish current eventloop %lx", current_evloop); 2676 return Qnil; 2677} 2678 2679static VALUE 2680lib_eventloop_launcher(check_root, update_flag, check_var, interp) 2681 int check_root; 2682 int update_flag; 2683 int *check_var; 2684 Tcl_Interp *interp; 2685{ 2686 volatile VALUE parent_evloop = eventloop_thread; 2687 struct evloop_params *args = ALLOC(struct evloop_params); 2688 /* struct evloop_params *args = RbTk_ALLOC_N(struct evloop_params, 1); */ 2689 2690 tcl_stubs_check(); 2691 2692 eventloop_thread = rb_thread_current(); 2693#ifdef RUBY_USE_NATIVE_THREAD 2694 tk_eventloop_thread_id = Tcl_GetCurrentThread(); 2695#endif 2696 2697 if (parent_evloop == eventloop_thread) { 2698 DUMP2("eventloop: recursive call on %lx", parent_evloop); 2699 rbtk_eventloop_depth++; 2700 } 2701 2702 if (!NIL_P(parent_evloop) && parent_evloop != eventloop_thread) { 2703 DUMP2("wait for stop of parent_evloop %lx", parent_evloop); 2704 while(!RTEST(rb_funcall(parent_evloop, ID_stop_p, 0))) { 2705 DUMP2("parent_evloop %lx doesn't stop", parent_evloop); 2706 rb_thread_run(parent_evloop); 2707 } 2708 DUMP1("succeed to stop parent"); 2709 } 2710 2711 rb_ary_push(eventloop_stack, parent_evloop); 2712 2713 DUMP3("tcltklib: eventloop-thread : %lx -> %lx\n", 2714 parent_evloop, eventloop_thread); 2715 2716 args->check_root = check_root; 2717 args->update_flag = update_flag; 2718 args->check_var = check_var; 2719 args->interp = interp; 2720 args->thr_crit_bup = rb_thread_critical; 2721 2722 rb_thread_critical = Qfalse; 2723 2724#if 0 2725 return rb_ensure(lib_eventloop_main, (VALUE)args, 2726 lib_eventloop_ensure, (VALUE)args); 2727#endif 2728 return rb_ensure(lib_eventloop_main_core, (VALUE)args, 2729 lib_eventloop_ensure, (VALUE)args); 2730} 2731 2732/* execute Tk_MainLoop */ 2733static VALUE 2734lib_mainloop(argc, argv, self) 2735 int argc; 2736 VALUE *argv; 2737 VALUE self; 2738{ 2739 VALUE check_rootwidget; 2740 2741 if (rb_scan_args(argc, argv, "01", &check_rootwidget) == 0) { 2742 check_rootwidget = Qtrue; 2743 } else if (RTEST(check_rootwidget)) { 2744 check_rootwidget = Qtrue; 2745 } else { 2746 check_rootwidget = Qfalse; 2747 } 2748 2749 return lib_eventloop_launcher(RTEST(check_rootwidget), 0, 2750 (int*)NULL, (Tcl_Interp*)NULL); 2751} 2752 2753static VALUE 2754ip_mainloop(argc, argv, self) 2755 int argc; 2756 VALUE *argv; 2757 VALUE self; 2758{ 2759 volatile VALUE ret; 2760 struct tcltkip *ptr = get_ip(self); 2761 2762 /* ip is deleted? */ 2763 if (deleted_ip(ptr)) { 2764 return Qnil; 2765 } 2766 2767 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { 2768 /* slave IP */ 2769 return Qnil; 2770 } 2771 2772 eventloop_interp = ptr->ip; 2773 ret = lib_mainloop(argc, argv, self); 2774 eventloop_interp = (Tcl_Interp*)NULL; 2775 return ret; 2776} 2777 2778 2779static VALUE 2780watchdog_evloop_launcher(check_rootwidget) 2781 VALUE check_rootwidget; 2782{ 2783 return lib_eventloop_launcher(RTEST(check_rootwidget), 0, 2784 (int*)NULL, (Tcl_Interp*)NULL); 2785} 2786 2787#define EVLOOP_WAKEUP_CHANCE 3 2788 2789static VALUE 2790lib_watchdog_core(check_rootwidget) 2791 VALUE check_rootwidget; 2792{ 2793 VALUE evloop; 2794 int prev_val = -1; 2795 int chance = 0; 2796 int check = RTEST(check_rootwidget); 2797 struct timeval t0, t1; 2798 2799 t0.tv_sec = 0; 2800 t0.tv_usec = (long)((NO_THREAD_INTERRUPT_TIME)*1000.0); 2801 t1.tv_sec = 0; 2802 t1.tv_usec = (long)((WATCHDOG_INTERVAL)*1000.0); 2803 2804 /* check other watchdog thread */ 2805 if (!NIL_P(watchdog_thread)) { 2806 if (RTEST(rb_funcall(watchdog_thread, ID_stop_p, 0))) { 2807 rb_funcall(watchdog_thread, ID_kill, 0); 2808 } else { 2809 return Qnil; 2810 } 2811 } 2812 watchdog_thread = rb_thread_current(); 2813 2814 /* watchdog start */ 2815 do { 2816 if (NIL_P(eventloop_thread) 2817 || (loop_counter == prev_val && chance >= EVLOOP_WAKEUP_CHANCE)) { 2818 /* start new eventloop thread */ 2819 DUMP2("eventloop thread %lx is sleeping or dead", 2820 eventloop_thread); 2821 evloop = rb_thread_create(watchdog_evloop_launcher, 2822 (void*)&check_rootwidget); 2823 DUMP2("create new eventloop thread %lx", evloop); 2824 loop_counter = -1; 2825 chance = 0; 2826 rb_thread_run(evloop); 2827 } else { 2828 prev_val = loop_counter; 2829 if (RTEST(rb_funcall(eventloop_thread, ID_stop_p, 0))) { 2830 ++chance; 2831 } else { 2832 chance = 0; 2833 } 2834 if (event_loop_wait_event) { 2835 rb_thread_wait_for(t0); 2836 } else { 2837 rb_thread_wait_for(t1); 2838 } 2839 /* rb_thread_schedule(); */ 2840 } 2841 } while(!check || !tk_stubs_init_p() || Tk_GetNumMainWindows() != 0); 2842 2843 return Qnil; 2844} 2845 2846VALUE 2847lib_watchdog_ensure(arg) 2848 VALUE arg; 2849{ 2850 eventloop_thread = Qnil; /* stop eventloops */ 2851#ifdef RUBY_USE_NATIVE_THREAD 2852 tk_eventloop_thread_id = (Tcl_ThreadId) 0; 2853#endif 2854 return Qnil; 2855} 2856 2857static VALUE 2858lib_mainloop_watchdog(argc, argv, self) 2859 int argc; 2860 VALUE *argv; 2861 VALUE self; 2862{ 2863 VALUE check_rootwidget; 2864 2865#ifdef RUBY_VM 2866 rb_raise(rb_eNotImpError, 2867 "eventloop_watchdog is not implemented on Ruby VM."); 2868#endif 2869 2870 if (rb_scan_args(argc, argv, "01", &check_rootwidget) == 0) { 2871 check_rootwidget = Qtrue; 2872 } else if (RTEST(check_rootwidget)) { 2873 check_rootwidget = Qtrue; 2874 } else { 2875 check_rootwidget = Qfalse; 2876 } 2877 2878 return rb_ensure(lib_watchdog_core, check_rootwidget, 2879 lib_watchdog_ensure, Qnil); 2880} 2881 2882static VALUE 2883ip_mainloop_watchdog(argc, argv, self) 2884 int argc; 2885 VALUE *argv; 2886 VALUE self; 2887{ 2888 struct tcltkip *ptr = get_ip(self); 2889 2890 /* ip is deleted? */ 2891 if (deleted_ip(ptr)) { 2892 return Qnil; 2893 } 2894 2895 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { 2896 /* slave IP */ 2897 return Qnil; 2898 } 2899 return lib_mainloop_watchdog(argc, argv, self); 2900} 2901 2902 2903/* thread-safe(?) interaction between Ruby and Tk */ 2904struct thread_call_proc_arg { 2905 VALUE proc; 2906 int *done; 2907}; 2908 2909void 2910_thread_call_proc_arg_mark(struct thread_call_proc_arg *q) 2911{ 2912 rb_gc_mark(q->proc); 2913} 2914 2915static VALUE 2916_thread_call_proc_core(arg) 2917 VALUE arg; 2918{ 2919 struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg; 2920 return rb_funcall(q->proc, ID_call, 0); 2921} 2922 2923static VALUE 2924_thread_call_proc_ensure(arg) 2925 VALUE arg; 2926{ 2927 struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg; 2928 *(q->done) = 1; 2929 return Qnil; 2930} 2931 2932static VALUE 2933_thread_call_proc(arg) 2934 VALUE arg; 2935{ 2936 struct thread_call_proc_arg *q = (struct thread_call_proc_arg*)arg; 2937 2938 return rb_ensure(_thread_call_proc_core, (VALUE)q, 2939 _thread_call_proc_ensure, (VALUE)q); 2940} 2941 2942static VALUE 2943#ifdef HAVE_PROTOTYPES 2944_thread_call_proc_value(VALUE th) 2945#else 2946_thread_call_proc_value(th) 2947 VALUE th; 2948#endif 2949{ 2950 return rb_funcall(th, ID_value, 0); 2951} 2952 2953static VALUE 2954lib_thread_callback(argc, argv, self) 2955 int argc; 2956 VALUE *argv; 2957 VALUE self; 2958{ 2959 struct thread_call_proc_arg *q; 2960 VALUE proc, th, ret; 2961 int status, foundEvent; 2962 2963 if (rb_scan_args(argc, argv, "01", &proc) == 0) { 2964 proc = rb_block_proc(); 2965 } 2966 2967 q = (struct thread_call_proc_arg *)ALLOC(struct thread_call_proc_arg); 2968 /* q = RbTk_ALLOC_N(struct thread_call_proc_arg, 1); */ 2969 q->proc = proc; 2970 q->done = (int*)ALLOC(int); 2971 /* q->done = RbTk_ALLOC_N(int, 1); */ 2972 *(q->done) = 0; 2973 2974 /* create call-proc thread */ 2975 th = rb_thread_create(_thread_call_proc, (void*)q); 2976 2977 rb_thread_schedule(); 2978 2979 /* start sub-eventloop */ 2980 foundEvent = RTEST(lib_eventloop_launcher(/* not check root-widget */0, 0, 2981 q->done, (Tcl_Interp*)NULL)); 2982 2983#ifdef RUBY_VM 2984 if (RTEST(rb_funcall(th, ID_alive_p, 0))) { 2985#else 2986 if (RTEST(rb_thread_alive_p(th))) { 2987#endif 2988 rb_funcall(th, ID_kill, 0); 2989 ret = Qnil; 2990 } else { 2991 ret = rb_protect(_thread_call_proc_value, th, &status); 2992 } 2993 2994 xfree(q->done); 2995 xfree(q); 2996 /* ckfree((char*)q->done); */ 2997 /* ckfree((char*)q); */ 2998 2999 if (NIL_P(rbtk_pending_exception)) { 3000 /* return rb_errinfo(); */ 3001 if (status) { 3002 rb_exc_raise(rb_errinfo()); 3003 } 3004 } else { 3005 VALUE exc = rbtk_pending_exception; 3006 rbtk_pending_exception = Qnil; 3007 /* return exc; */ 3008 rb_exc_raise(exc); 3009 } 3010 3011 return ret; 3012} 3013 3014 3015/* do_one_event */ 3016static VALUE 3017lib_do_one_event_core(argc, argv, self, is_ip) 3018 int argc; 3019 VALUE *argv; 3020 VALUE self; 3021 int is_ip; 3022{ 3023 volatile VALUE vflags; 3024 int flags; 3025 int found_event; 3026 3027 if (!NIL_P(eventloop_thread)) { 3028 rb_raise(rb_eRuntimeError, "eventloop is already running"); 3029 } 3030 3031 tcl_stubs_check(); 3032 3033 if (rb_scan_args(argc, argv, "01", &vflags) == 0) { 3034 flags = TCL_ALL_EVENTS | TCL_DONT_WAIT; 3035 } else { 3036 Check_Type(vflags, T_FIXNUM); 3037 flags = FIX2INT(vflags); 3038 } 3039 3040 if (rb_safe_level() >= 4 || (rb_safe_level() >=1 && OBJ_TAINTED(vflags))) { 3041 flags |= TCL_DONT_WAIT; 3042 } 3043 3044 if (is_ip) { 3045 /* check IP */ 3046 struct tcltkip *ptr = get_ip(self); 3047 3048 /* ip is deleted? */ 3049 if (deleted_ip(ptr)) { 3050 return Qfalse; 3051 } 3052 3053 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { 3054 /* slave IP */ 3055 flags |= TCL_DONT_WAIT; 3056 } 3057 } 3058 3059 /* found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT); */ 3060 found_event = Tcl_DoOneEvent(flags); 3061 3062 if (pending_exception_check0()) { 3063 return Qfalse; 3064 } 3065 3066 if (found_event) { 3067 return Qtrue; 3068 } else { 3069 return Qfalse; 3070 } 3071} 3072 3073static VALUE 3074lib_do_one_event(argc, argv, self) 3075 int argc; 3076 VALUE *argv; 3077 VALUE self; 3078{ 3079 return lib_do_one_event_core(argc, argv, self, 0); 3080} 3081 3082static VALUE 3083ip_do_one_event(argc, argv, self) 3084 int argc; 3085 VALUE *argv; 3086 VALUE self; 3087{ 3088 return lib_do_one_event_core(argc, argv, self, 0); 3089} 3090 3091 3092static void 3093ip_set_exc_message(interp, exc) 3094 Tcl_Interp *interp; 3095 VALUE exc; 3096{ 3097 char *buf; 3098 Tcl_DString dstr; 3099 volatile VALUE msg; 3100 int thr_crit_bup; 3101 3102#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0) 3103 volatile VALUE enc; 3104 Tcl_Encoding encoding; 3105#endif 3106 3107 thr_crit_bup = rb_thread_critical; 3108 rb_thread_critical = Qtrue; 3109 3110 msg = rb_funcall(exc, ID_message, 0, 0); 3111 StringValue(msg); 3112 3113#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0) 3114 enc = rb_attr_get(exc, ID_at_enc); 3115 if (NIL_P(enc)) { 3116 enc = rb_attr_get(msg, ID_at_enc); 3117 } 3118 if (NIL_P(enc)) { 3119 encoding = (Tcl_Encoding)NULL; 3120 } else if (TYPE(enc) == T_STRING) { 3121 /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */ 3122 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(enc)); 3123 } else { 3124 enc = rb_funcall(enc, ID_to_s, 0, 0); 3125 /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */ 3126 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(enc)); 3127 } 3128 3129 /* to avoid a garbled error message dialog */ 3130 /* buf = ALLOC_N(char, (RSTRING(msg)->len)+1);*/ 3131 /* memcpy(buf, RSTRING(msg)->ptr, RSTRING(msg)->len);*/ 3132 /* buf[RSTRING(msg)->len] = 0; */ 3133 buf = ALLOC_N(char, RSTRING_LENINT(msg)+1); 3134 /* buf = ckalloc(RSTRING_LENINT(msg)+1); */ 3135 memcpy(buf, RSTRING_PTR(msg), RSTRING_LEN(msg)); 3136 buf[RSTRING_LEN(msg)] = 0; 3137 3138 Tcl_DStringInit(&dstr); 3139 Tcl_DStringFree(&dstr); 3140 Tcl_ExternalToUtfDString(encoding, buf, RSTRING_LENINT(msg), &dstr); 3141 3142 Tcl_AppendResult(interp, Tcl_DStringValue(&dstr), (char*)NULL); 3143 DUMP2("error message:%s", Tcl_DStringValue(&dstr)); 3144 Tcl_DStringFree(&dstr); 3145 xfree(buf); 3146 /* ckfree(buf); */ 3147 3148#else /* TCL_VERSION <= 8.0 */ 3149 Tcl_AppendResult(interp, RSTRING_PTR(msg), (char*)NULL); 3150#endif 3151 3152 rb_thread_critical = thr_crit_bup; 3153} 3154 3155static VALUE 3156TkStringValue(obj) 3157 VALUE obj; 3158{ 3159 switch(TYPE(obj)) { 3160 case T_STRING: 3161 return obj; 3162 3163 case T_NIL: 3164 return rb_str_new2(""); 3165 3166 case T_TRUE: 3167 return rb_str_new2("1"); 3168 3169 case T_FALSE: 3170 return rb_str_new2("0"); 3171 3172 case T_ARRAY: 3173 return rb_funcall(obj, ID_join, 1, rb_str_new2(" ")); 3174 3175 default: 3176 if (rb_respond_to(obj, ID_to_s)) { 3177 return rb_funcall(obj, ID_to_s, 0, 0); 3178 } 3179 } 3180 3181 return rb_funcall(obj, ID_inspect, 0, 0); 3182} 3183 3184static int 3185#ifdef HAVE_PROTOTYPES 3186tcl_protect_core(Tcl_Interp *interp, VALUE (*proc)(VALUE), VALUE data) 3187#else 3188tcl_protect_core(interp, proc, data) /* should not raise exception */ 3189 Tcl_Interp *interp; 3190 VALUE (*proc)(); 3191 VALUE data; 3192#endif 3193{ 3194 volatile VALUE ret, exc = Qnil; 3195 int status = 0; 3196 int thr_crit_bup = rb_thread_critical; 3197 3198 Tcl_ResetResult(interp); 3199 3200 rb_thread_critical = Qfalse; 3201 ret = rb_protect(proc, data, &status); 3202 rb_thread_critical = Qtrue; 3203 if (status) { 3204 char *buf; 3205 VALUE old_gc; 3206 volatile VALUE type, str; 3207 3208 old_gc = rb_gc_disable(); 3209 3210 switch(status) { 3211 case TAG_RETURN: 3212 type = eTkCallbackReturn; 3213 goto error; 3214 case TAG_BREAK: 3215 type = eTkCallbackBreak; 3216 goto error; 3217 case TAG_NEXT: 3218 type = eTkCallbackContinue; 3219 goto error; 3220 error: 3221 str = rb_str_new2("LocalJumpError: "); 3222 rb_str_append(str, rb_obj_as_string(rb_errinfo())); 3223 exc = rb_exc_new3(type, str); 3224 break; 3225 3226 case TAG_RETRY: 3227 if (NIL_P(rb_errinfo())) { 3228 DUMP1("rb_protect: retry"); 3229 exc = rb_exc_new2(eTkCallbackRetry, "retry jump error"); 3230 } else { 3231 exc = rb_errinfo(); 3232 } 3233 break; 3234 3235 case TAG_REDO: 3236 if (NIL_P(rb_errinfo())) { 3237 DUMP1("rb_protect: redo"); 3238 exc = rb_exc_new2(eTkCallbackRedo, "redo jump error"); 3239 } else { 3240 exc = rb_errinfo(); 3241 } 3242 break; 3243 3244 case TAG_RAISE: 3245 if (NIL_P(rb_errinfo())) { 3246 exc = rb_exc_new2(rb_eException, "unknown exception"); 3247 } else { 3248 exc = rb_errinfo(); 3249 } 3250 break; 3251 3252 case TAG_FATAL: 3253 if (NIL_P(rb_errinfo())) { 3254 exc = rb_exc_new2(rb_eFatal, "FATAL"); 3255 } else { 3256 exc = rb_errinfo(); 3257 } 3258 break; 3259 3260 case TAG_THROW: 3261 if (NIL_P(rb_errinfo())) { 3262 DUMP1("rb_protect: throw"); 3263 exc = rb_exc_new2(eTkCallbackThrow, "throw jump error"); 3264 } else { 3265 exc = rb_errinfo(); 3266 } 3267 break; 3268 3269 default: 3270 buf = ALLOC_N(char, 256); 3271 /* buf = ckalloc(sizeof(char) * 256); */ 3272 sprintf(buf, "unknown loncaljmp status %d", status); 3273 exc = rb_exc_new2(rb_eException, buf); 3274 xfree(buf); 3275 /* ckfree(buf); */ 3276 break; 3277 } 3278 3279 if (old_gc == Qfalse) rb_gc_enable(); 3280 3281 ret = Qnil; 3282 } 3283 3284 rb_thread_critical = thr_crit_bup; 3285 3286 Tcl_ResetResult(interp); 3287 3288 /* status check */ 3289 if (!NIL_P(exc)) { 3290 volatile VALUE eclass = rb_obj_class(exc); 3291 volatile VALUE backtrace; 3292 3293 DUMP1("(failed)"); 3294 3295 thr_crit_bup = rb_thread_critical; 3296 rb_thread_critical = Qtrue; 3297 3298 DUMP1("set backtrace"); 3299 if (!NIL_P(backtrace = rb_funcall(exc, ID_backtrace, 0, 0))) { 3300 backtrace = rb_ary_join(backtrace, rb_str_new2("\n")); 3301 Tcl_AddErrorInfo(interp, StringValuePtr(backtrace)); 3302 } 3303 3304 rb_thread_critical = thr_crit_bup; 3305 3306 ip_set_exc_message(interp, exc); 3307 3308 if (eclass == eTkCallbackReturn) 3309 return TCL_RETURN; 3310 3311 if (eclass == eTkCallbackBreak) 3312 return TCL_BREAK; 3313 3314 if (eclass == eTkCallbackContinue) 3315 return TCL_CONTINUE; 3316 3317 if (eclass == rb_eSystemExit || eclass == rb_eInterrupt) { 3318 rbtk_pending_exception = exc; 3319 return TCL_RETURN; 3320 } 3321 3322 if (rb_obj_is_kind_of(exc, eTkLocalJumpError)) { 3323 rbtk_pending_exception = exc; 3324 return TCL_ERROR; 3325 } 3326 3327 if (rb_obj_is_kind_of(exc, eLocalJumpError)) { 3328 VALUE reason = rb_ivar_get(exc, ID_at_reason); 3329 3330 if (TYPE(reason) == T_SYMBOL) { 3331 if (SYM2ID(reason) == ID_return) 3332 return TCL_RETURN; 3333 3334 if (SYM2ID(reason) == ID_break) 3335 return TCL_BREAK; 3336 3337 if (SYM2ID(reason) == ID_next) 3338 return TCL_CONTINUE; 3339 } 3340 } 3341 3342 return TCL_ERROR; 3343 } 3344 3345 /* result must be string or nil */ 3346 if (!NIL_P(ret)) { 3347 /* copy result to the tcl interpreter */ 3348 thr_crit_bup = rb_thread_critical; 3349 rb_thread_critical = Qtrue; 3350 3351 ret = TkStringValue(ret); 3352 DUMP1("Tcl_AppendResult"); 3353 Tcl_AppendResult(interp, RSTRING_PTR(ret), (char *)NULL); 3354 3355 rb_thread_critical = thr_crit_bup; 3356 } 3357 3358 DUMP2("(result) %s", NIL_P(ret) ? "nil" : RSTRING_PTR(ret)); 3359 3360 return TCL_OK; 3361} 3362 3363static int 3364tcl_protect(interp, proc, data) 3365 Tcl_Interp *interp; 3366 VALUE (*proc)(); 3367 VALUE data; 3368{ 3369 int code; 3370 3371#ifdef HAVE_NATIVETHREAD 3372#ifndef RUBY_USE_NATIVE_THREAD 3373 if (!ruby_native_thread_p()) { 3374 rb_bug("cross-thread violation on tcl_protect()"); 3375 } 3376#endif 3377#endif 3378 3379#ifdef RUBY_VM 3380 code = tcl_protect_core(interp, proc, data); 3381#else 3382 do { 3383 int old_trapflag = rb_trap_immediate; 3384 rb_trap_immediate = 0; 3385 code = tcl_protect_core(interp, proc, data); 3386 rb_trap_immediate = old_trapflag; 3387 } while (0); 3388#endif 3389 3390 return code; 3391} 3392 3393static int 3394#if TCL_MAJOR_VERSION >= 8 3395ip_ruby_eval(clientData, interp, argc, argv) 3396 ClientData clientData; 3397 Tcl_Interp *interp; 3398 int argc; 3399 Tcl_Obj *CONST argv[]; 3400#else /* TCL_MAJOR_VERSION < 8 */ 3401ip_ruby_eval(clientData, interp, argc, argv) 3402 ClientData clientData; 3403 Tcl_Interp *interp; 3404 int argc; 3405 char *argv[]; 3406#endif 3407{ 3408 char *arg; 3409 int thr_crit_bup; 3410 int code; 3411 3412 if (interp == (Tcl_Interp*)NULL) { 3413 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, 3414 "IP is deleted"); 3415 return TCL_ERROR; 3416 } 3417 3418 /* ruby command has 1 arg. */ 3419 if (argc != 2) { 3420#if 0 3421 rb_raise(rb_eArgError, 3422 "wrong number of arguments (%d for 1)", argc - 1); 3423#else 3424 char buf[sizeof(int)*8 + 1]; 3425 Tcl_ResetResult(interp); 3426 sprintf(buf, "%d", argc-1); 3427 Tcl_AppendResult(interp, "wrong number of arguments (", 3428 buf, " for 1)", (char *)NULL); 3429 rbtk_pending_exception = rb_exc_new2(rb_eArgError, 3430 Tcl_GetStringResult(interp)); 3431 return TCL_ERROR; 3432#endif 3433 } 3434 3435 /* get C string from Tcl object */ 3436#if TCL_MAJOR_VERSION >= 8 3437 { 3438 char *str; 3439 int len; 3440 3441 thr_crit_bup = rb_thread_critical; 3442 rb_thread_critical = Qtrue; 3443 3444 str = Tcl_GetStringFromObj(argv[1], &len); 3445 arg = ALLOC_N(char, len + 1); 3446 /* arg = ckalloc(sizeof(char) * (len + 1)); */ 3447 memcpy(arg, str, len); 3448 arg[len] = 0; 3449 3450 rb_thread_critical = thr_crit_bup; 3451 3452 } 3453#else /* TCL_MAJOR_VERSION < 8 */ 3454 arg = argv[1]; 3455#endif 3456 3457 /* evaluate the argument string by ruby */ 3458 DUMP2("rb_eval_string(%s)", arg); 3459 3460 code = tcl_protect(interp, rb_eval_string, (VALUE)arg); 3461 3462#if TCL_MAJOR_VERSION >= 8 3463 xfree(arg); 3464 /* ckfree(arg); */ 3465#endif 3466 3467 return code; 3468} 3469 3470 3471/* Tcl command `ruby_cmd' */ 3472static VALUE 3473ip_ruby_cmd_core(arg) 3474 struct cmd_body_arg *arg; 3475{ 3476 volatile VALUE ret; 3477 int thr_crit_bup; 3478 3479 DUMP1("call ip_ruby_cmd_core"); 3480 thr_crit_bup = rb_thread_critical; 3481 rb_thread_critical = Qfalse; 3482 ret = rb_apply(arg->receiver, arg->method, arg->args); 3483 DUMP2("rb_apply return:%lx", ret); 3484 rb_thread_critical = thr_crit_bup; 3485 DUMP1("finish ip_ruby_cmd_core"); 3486 3487 return ret; 3488} 3489 3490#define SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER 1 3491 3492static VALUE 3493ip_ruby_cmd_receiver_const_get(name) 3494 char *name; 3495{ 3496 volatile VALUE klass = rb_cObject; 3497#if 0 3498 char *head, *tail; 3499#endif 3500 int state; 3501 3502#if SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER 3503 klass = rb_eval_string_protect(name, &state); 3504 if (state) { 3505 return Qnil; 3506 } else { 3507 return klass; 3508 } 3509#else 3510 return rb_const_get(klass, rb_intern(name)); 3511#endif 3512 3513 /* TODO!!!!!! */ 3514 /* support nest of classes/modules */ 3515 3516 /* return rb_eval_string(name); */ 3517 /* return rb_eval_string_protect(name, &state); */ 3518 3519#if 0 /* doesn't work!! (fail to autoload?) */ 3520 /* duplicate */ 3521 head = name = strdup(name); 3522 3523 /* has '::' at head ? */ 3524 if (*head == ':') head += 2; 3525 tail = head; 3526 3527 /* search */ 3528 while(*tail) { 3529 if (*tail == ':') { 3530 *tail = '\0'; 3531 klass = rb_const_get(klass, rb_intern(head)); 3532 tail += 2; 3533 head = tail; 3534 } else { 3535 tail++; 3536 } 3537 } 3538 3539 free(name); 3540 return rb_const_get(klass, rb_intern(head)); 3541#endif 3542} 3543 3544static VALUE 3545ip_ruby_cmd_receiver_get(str) 3546 char *str; 3547{ 3548 volatile VALUE receiver; 3549#if !SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER 3550 int state; 3551#endif 3552 3553 if (str[0] == ':' || ('A' <= str[0] && str[0] <= 'Z')) { 3554 /* class | module | constant */ 3555#if SUPPORT_NESTED_CONST_AS_IP_RUBY_CMD_RECEIVER 3556 receiver = ip_ruby_cmd_receiver_const_get(str); 3557#else 3558 receiver = rb_protect(ip_ruby_cmd_receiver_const_get, (VALUE)str, &state); 3559 if (state) return Qnil; 3560#endif 3561 } else if (str[0] == '$') { 3562 /* global variable */ 3563 receiver = rb_gv_get(str); 3564 } else { 3565 /* global variable omitted '$' */ 3566 char *buf; 3567 size_t len; 3568 3569 len = strlen(str); 3570 buf = ALLOC_N(char, len + 2); 3571 /* buf = ckalloc(sizeof(char) * (len + 2)); */ 3572 buf[0] = '$'; 3573 memcpy(buf + 1, str, len); 3574 buf[len + 1] = 0; 3575 receiver = rb_gv_get(buf); 3576 xfree(buf); 3577 /* ckfree(buf); */ 3578 } 3579 3580 return receiver; 3581} 3582 3583/* ruby_cmd receiver method arg ... */ 3584static int 3585#if TCL_MAJOR_VERSION >= 8 3586ip_ruby_cmd(clientData, interp, argc, argv) 3587 ClientData clientData; 3588 Tcl_Interp *interp; 3589 int argc; 3590 Tcl_Obj *CONST argv[]; 3591#else /* TCL_MAJOR_VERSION < 8 */ 3592ip_ruby_cmd(clientData, interp, argc, argv) 3593 ClientData clientData; 3594 Tcl_Interp *interp; 3595 int argc; 3596 char *argv[]; 3597#endif 3598{ 3599 volatile VALUE receiver; 3600 volatile ID method; 3601 volatile VALUE args; 3602 char *str; 3603 int i; 3604 int len; 3605 struct cmd_body_arg *arg; 3606 int thr_crit_bup; 3607 VALUE old_gc; 3608 int code; 3609 3610 if (interp == (Tcl_Interp*)NULL) { 3611 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, 3612 "IP is deleted"); 3613 return TCL_ERROR; 3614 } 3615 3616 if (argc < 3) { 3617#if 0 3618 rb_raise(rb_eArgError, "too few arguments"); 3619#else 3620 Tcl_ResetResult(interp); 3621 Tcl_AppendResult(interp, "too few arguments", (char *)NULL); 3622 rbtk_pending_exception = rb_exc_new2(rb_eArgError, 3623 Tcl_GetStringResult(interp)); 3624 return TCL_ERROR; 3625#endif 3626 } 3627 3628 /* get arguments from Tcl objects */ 3629 thr_crit_bup = rb_thread_critical; 3630 rb_thread_critical = Qtrue; 3631 old_gc = rb_gc_disable(); 3632 3633 /* get receiver */ 3634#if TCL_MAJOR_VERSION >= 8 3635 str = Tcl_GetStringFromObj(argv[1], &len); 3636#else /* TCL_MAJOR_VERSION < 8 */ 3637 str = argv[1]; 3638#endif 3639 DUMP2("receiver:%s",str); 3640 /* receiver = rb_protect(ip_ruby_cmd_receiver_get, (VALUE)str, &code); */ 3641 receiver = ip_ruby_cmd_receiver_get(str); 3642 if (NIL_P(receiver)) { 3643#if 0 3644 rb_raise(rb_eArgError, 3645 "unknown class/module/global-variable '%s'", str); 3646#else 3647 Tcl_ResetResult(interp); 3648 Tcl_AppendResult(interp, "unknown class/module/global-variable '", 3649 str, "'", (char *)NULL); 3650 rbtk_pending_exception = rb_exc_new2(rb_eArgError, 3651 Tcl_GetStringResult(interp)); 3652 if (old_gc == Qfalse) rb_gc_enable(); 3653 return TCL_ERROR; 3654#endif 3655 } 3656 3657 /* get metrhod */ 3658#if TCL_MAJOR_VERSION >= 8 3659 str = Tcl_GetStringFromObj(argv[2], &len); 3660#else /* TCL_MAJOR_VERSION < 8 */ 3661 str = argv[2]; 3662#endif 3663 method = rb_intern(str); 3664 3665 /* get args */ 3666 args = rb_ary_new2(argc - 2); 3667 for(i = 3; i < argc; i++) { 3668 VALUE s; 3669#if TCL_MAJOR_VERSION >= 8 3670 str = Tcl_GetStringFromObj(argv[i], &len); 3671 s = rb_tainted_str_new(str, len); 3672#else /* TCL_MAJOR_VERSION < 8 */ 3673 str = argv[i]; 3674 s = rb_tainted_str_new2(str); 3675#endif 3676 DUMP2("arg:%s",str); 3677#ifndef HAVE_STRUCT_RARRAY_LEN 3678 rb_ary_push(args, s); 3679#else 3680 RARRAY(args)->ptr[RARRAY(args)->len++] = s; 3681#endif 3682 } 3683 3684 if (old_gc == Qfalse) rb_gc_enable(); 3685 rb_thread_critical = thr_crit_bup; 3686 3687 /* allocate */ 3688 arg = ALLOC(struct cmd_body_arg); 3689 /* arg = RbTk_ALLOC_N(struct cmd_body_arg, 1); */ 3690 3691 arg->receiver = receiver; 3692 arg->method = method; 3693 arg->args = args; 3694 3695 /* evaluate the argument string by ruby */ 3696 code = tcl_protect(interp, ip_ruby_cmd_core, (VALUE)arg); 3697 3698 xfree(arg); 3699 /* ckfree((char*)arg); */ 3700 3701 return code; 3702} 3703 3704 3705/*****************************/ 3706/* relpace of 'exit' command */ 3707/*****************************/ 3708static int 3709#if TCL_MAJOR_VERSION >= 8 3710#ifdef HAVE_PROTOTYPES 3711ip_InterpExitObjCmd(ClientData clientData, Tcl_Interp *interp, 3712 int argc, Tcl_Obj *CONST argv[]) 3713#else 3714ip_InterpExitObjCmd(clientData, interp, argc, argv) 3715 ClientData clientData; 3716 Tcl_Interp *interp; 3717 int argc; 3718 Tcl_Obj *CONST argv[]; 3719#endif 3720#else /* TCL_MAJOR_VERSION < 8 */ 3721#ifdef HAVE_PROTOTYPES 3722ip_InterpExitCommand(ClientData clientData, Tcl_Interp *interp, 3723 int argc, char *argv[]) 3724#else 3725ip_InterpExitCommand(clientData, interp, argc, argv) 3726 ClientData clientData; 3727 Tcl_Interp *interp; 3728 int argc; 3729 char *argv[]; 3730#endif 3731#endif 3732{ 3733 DUMP1("start ip_InterpExitCommand"); 3734 if (interp != (Tcl_Interp*)NULL 3735 && !Tcl_InterpDeleted(interp) 3736#if TCL_NAMESPACE_DEBUG 3737 && !ip_null_namespace(interp) 3738#endif 3739 ) { 3740 Tcl_ResetResult(interp); 3741 /* Tcl_Preserve(interp); */ 3742 /* Tcl_Eval(interp, "interp eval {} {destroy .}; interp delete {}"); */ 3743 if (!Tcl_InterpDeleted(interp)) { 3744 ip_finalize(interp); 3745 3746 Tcl_DeleteInterp(interp); 3747 Tcl_Release(interp); 3748 } 3749 } 3750 return TCL_OK; 3751} 3752 3753static int 3754#if TCL_MAJOR_VERSION >= 8 3755#ifdef HAVE_PROTOTYPES 3756ip_RubyExitObjCmd(ClientData clientData, Tcl_Interp *interp, 3757 int argc, Tcl_Obj *CONST argv[]) 3758#else 3759ip_RubyExitObjCmd(clientData, interp, argc, argv) 3760 ClientData clientData; 3761 Tcl_Interp *interp; 3762 int argc; 3763 Tcl_Obj *CONST argv[]; 3764#endif 3765#else /* TCL_MAJOR_VERSION < 8 */ 3766#ifdef HAVE_PROTOTYPES 3767ip_RubyExitCommand(ClientData clientData, Tcl_Interp *interp, 3768 int argc, char *argv[]) 3769#else 3770ip_RubyExitCommand(clientData, interp, argc, argv) 3771 ClientData clientData; 3772 Tcl_Interp *interp; 3773 int argc; 3774 char *argv[]; 3775#endif 3776#endif 3777{ 3778 int state; 3779 char *cmd, *param; 3780#if TCL_MAJOR_VERSION < 8 3781 char *endptr; 3782 cmd = argv[0]; 3783#endif 3784 3785 DUMP1("start ip_RubyExitCommand"); 3786 3787#if TCL_MAJOR_VERSION >= 8 3788 /* cmd = Tcl_GetString(argv[0]); */ 3789 cmd = Tcl_GetStringFromObj(argv[0], (int*)NULL); 3790#endif 3791 3792 if (argc < 1 || argc > 2) { 3793 /* arguemnt error */ 3794 Tcl_AppendResult(interp, 3795 "wrong number of arguments: should be \"", 3796 cmd, " ?returnCode?\"", (char *)NULL); 3797 return TCL_ERROR; 3798 } 3799 3800 if (interp == (Tcl_Interp*)NULL) return TCL_OK; 3801 3802 Tcl_ResetResult(interp); 3803 3804 if (rb_safe_level() >= 4 || Tcl_IsSafe(interp)) { 3805 if (!Tcl_InterpDeleted(interp)) { 3806 ip_finalize(interp); 3807 3808 Tcl_DeleteInterp(interp); 3809 Tcl_Release(interp); 3810 } 3811 return TCL_OK; 3812 } 3813 3814 switch(argc) { 3815 case 1: 3816 /* rb_exit(0); */ /* not return if succeed */ 3817 Tcl_AppendResult(interp, 3818 "fail to call \"", cmd, "\"", (char *)NULL); 3819 3820 rbtk_pending_exception = rb_exc_new2(rb_eSystemExit, 3821 Tcl_GetStringResult(interp)); 3822 rb_iv_set(rbtk_pending_exception, "status", INT2FIX(0)); 3823 3824 return TCL_RETURN; 3825 3826 case 2: 3827#if TCL_MAJOR_VERSION >= 8 3828 if (Tcl_GetIntFromObj(interp, argv[1], &state) == TCL_ERROR) { 3829 return TCL_ERROR; 3830 } 3831 /* param = Tcl_GetString(argv[1]); */ 3832 param = Tcl_GetStringFromObj(argv[1], (int*)NULL); 3833#else /* TCL_MAJOR_VERSION < 8 */ 3834 state = (int)strtol(argv[1], &endptr, 0); 3835 if (*endptr) { 3836 Tcl_AppendResult(interp, 3837 "expected integer but got \"", 3838 argv[1], "\"", (char *)NULL); 3839 return TCL_ERROR; 3840 } 3841 param = argv[1]; 3842#endif 3843 /* rb_exit(state); */ /* not return if succeed */ 3844 3845 Tcl_AppendResult(interp, "fail to call \"", cmd, " ", 3846 param, "\"", (char *)NULL); 3847 3848 rbtk_pending_exception = rb_exc_new2(rb_eSystemExit, 3849 Tcl_GetStringResult(interp)); 3850 rb_iv_set(rbtk_pending_exception, "status", INT2FIX(state)); 3851 3852 return TCL_RETURN; 3853 3854 default: 3855 /* arguemnt error */ 3856 Tcl_AppendResult(interp, 3857 "wrong number of arguments: should be \"", 3858 cmd, " ?returnCode?\"", (char *)NULL); 3859 return TCL_ERROR; 3860 } 3861} 3862 3863 3864/**************************/ 3865/* based on tclEvent.c */ 3866/**************************/ 3867 3868/*********************/ 3869/* replace of update */ 3870/*********************/ 3871#if TCL_MAJOR_VERSION >= 8 3872static int ip_rbUpdateObjCmd _((ClientData, Tcl_Interp *, int, 3873 Tcl_Obj *CONST [])); 3874static int 3875ip_rbUpdateObjCmd(clientData, interp, objc, objv) 3876 ClientData clientData; 3877 Tcl_Interp *interp; 3878 int objc; 3879 Tcl_Obj *CONST objv[]; 3880#else /* TCL_MAJOR_VERSION < 8 */ 3881static int ip_rbUpdateCommand _((ClientData, Tcl_Interp *, int, char *[])); 3882static int 3883ip_rbUpdateCommand(clientData, interp, objc, objv) 3884 ClientData clientData; 3885 Tcl_Interp *interp; 3886 int objc; 3887 char *objv[]; 3888#endif 3889{ 3890 int optionIndex; 3891 int ret; 3892 int flags = 0; 3893 static CONST char *updateOptions[] = {"idletasks", (char *) NULL}; 3894 enum updateOptions {REGEXP_IDLETASKS}; 3895 3896 DUMP1("Ruby's 'update' is called"); 3897 if (interp == (Tcl_Interp*)NULL) { 3898 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, 3899 "IP is deleted"); 3900 return TCL_ERROR; 3901 } 3902#ifdef HAVE_NATIVETHREAD 3903#ifndef RUBY_USE_NATIVE_THREAD 3904 if (!ruby_native_thread_p()) { 3905 rb_bug("cross-thread violation on ip_ruby_eval()"); 3906 } 3907#endif 3908#endif 3909 3910 Tcl_ResetResult(interp); 3911 3912 if (objc == 1) { 3913 flags = TCL_DONT_WAIT; 3914 3915 } else if (objc == 2) { 3916#if TCL_MAJOR_VERSION >= 8 3917 if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)updateOptions, 3918 "option", 0, &optionIndex) != TCL_OK) { 3919 return TCL_ERROR; 3920 } 3921 switch ((enum updateOptions) optionIndex) { 3922 case REGEXP_IDLETASKS: { 3923 flags = TCL_IDLE_EVENTS; 3924 break; 3925 } 3926 default: { 3927 rb_bug("ip_rbUpdateObjCmd: bad option index to UpdateOptions"); 3928 } 3929 } 3930#else 3931 if (strncmp(objv[1], "idletasks", strlen(objv[1])) != 0) { 3932 Tcl_AppendResult(interp, "bad option \"", objv[1], 3933 "\": must be idletasks", (char *) NULL); 3934 return TCL_ERROR; 3935 } 3936 flags = TCL_IDLE_EVENTS; 3937#endif 3938 } else { 3939#ifdef Tcl_WrongNumArgs 3940 Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]"); 3941#else 3942# if TCL_MAJOR_VERSION >= 8 3943 int dummy; 3944 Tcl_AppendResult(interp, "wrong number of arguments: should be \"", 3945 Tcl_GetStringFromObj(objv[0], &dummy), 3946 " [ idletasks ]\"", 3947 (char *) NULL); 3948# else /* TCL_MAJOR_VERSION < 8 */ 3949 Tcl_AppendResult(interp, "wrong number of arguments: should be \"", 3950 objv[0], " [ idletasks ]\"", (char *) NULL); 3951# endif 3952#endif 3953 return TCL_ERROR; 3954 } 3955 3956 Tcl_Preserve(interp); 3957 3958 /* call eventloop */ 3959 /* ret = lib_eventloop_core(0, flags, (int *)NULL);*/ /* ignore result */ 3960 ret = RTEST(lib_eventloop_launcher(0, flags, (int *)NULL, interp)); /* ignore result */ 3961 3962 /* exception check */ 3963 if (!NIL_P(rbtk_pending_exception)) { 3964 Tcl_Release(interp); 3965 3966 /* 3967 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) { 3968 */ 3969 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit) 3970 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) { 3971 return TCL_RETURN; 3972 } else{ 3973 return TCL_ERROR; 3974 } 3975 } 3976 3977 /* trap check */ 3978#ifdef RUBY_VM 3979 if (rb_thread_check_trap_pending()) { 3980#else 3981 if (rb_trap_pending) { 3982#endif 3983 Tcl_Release(interp); 3984 3985 return TCL_RETURN; 3986 } 3987 3988 /* 3989 * Must clear the interpreter's result because event handlers could 3990 * have executed commands. 3991 */ 3992 3993 DUMP2("last result '%s'", Tcl_GetStringResult(interp)); 3994 Tcl_ResetResult(interp); 3995 Tcl_Release(interp); 3996 3997 DUMP1("finish Ruby's 'update'"); 3998 return TCL_OK; 3999} 4000 4001 4002/**********************/ 4003/* update with thread */ 4004/**********************/ 4005struct th_update_param { 4006 VALUE thread; 4007 int done; 4008}; 4009 4010static void rb_threadUpdateProc _((ClientData)); 4011static void 4012rb_threadUpdateProc(clientData) 4013 ClientData clientData; /* Pointer to integer to set to 1. */ 4014{ 4015 struct th_update_param *param = (struct th_update_param *) clientData; 4016 4017 DUMP1("threadUpdateProc is called"); 4018 param->done = 1; 4019 rb_thread_wakeup(param->thread); 4020 4021 return; 4022} 4023 4024#if TCL_MAJOR_VERSION >= 8 4025static int ip_rb_threadUpdateObjCmd _((ClientData, Tcl_Interp *, int, 4026 Tcl_Obj *CONST [])); 4027static int 4028ip_rb_threadUpdateObjCmd(clientData, interp, objc, objv) 4029 ClientData clientData; 4030 Tcl_Interp *interp; 4031 int objc; 4032 Tcl_Obj *CONST objv[]; 4033#else /* TCL_MAJOR_VERSION < 8 */ 4034static int ip_rb_threadUpdateCommand _((ClientData, Tcl_Interp *, int, 4035 char *[])); 4036static int 4037ip_rb_threadUpdateCommand(clientData, interp, objc, objv) 4038 ClientData clientData; 4039 Tcl_Interp *interp; 4040 int objc; 4041 char *objv[]; 4042#endif 4043{ 4044 int optionIndex; 4045 int flags = 0; 4046 struct th_update_param *param; 4047 static CONST char *updateOptions[] = {"idletasks", (char *) NULL}; 4048 enum updateOptions {REGEXP_IDLETASKS}; 4049 volatile VALUE current_thread = rb_thread_current(); 4050 struct timeval t; 4051 4052 DUMP1("Ruby's 'thread_update' is called"); 4053 if (interp == (Tcl_Interp*)NULL) { 4054 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, 4055 "IP is deleted"); 4056 return TCL_ERROR; 4057 } 4058#ifdef HAVE_NATIVETHREAD 4059#ifndef RUBY_USE_NATIVE_THREAD 4060 if (!ruby_native_thread_p()) { 4061 rb_bug("cross-thread violation on ip_rb_threadUpdateCommand()"); 4062 } 4063#endif 4064#endif 4065 4066 if (rb_thread_alone() 4067 || NIL_P(eventloop_thread) || eventloop_thread == current_thread) { 4068#if TCL_MAJOR_VERSION >= 8 4069 DUMP1("call ip_rbUpdateObjCmd"); 4070 return ip_rbUpdateObjCmd(clientData, interp, objc, objv); 4071#else /* TCL_MAJOR_VERSION < 8 */ 4072 DUMP1("call ip_rbUpdateCommand"); 4073 return ip_rbUpdateCommand(clientData, interp, objc, objv); 4074#endif 4075 } 4076 4077 DUMP1("start Ruby's 'thread_update' body"); 4078 4079 Tcl_ResetResult(interp); 4080 4081 if (objc == 1) { 4082 flags = TCL_DONT_WAIT; 4083 4084 } else if (objc == 2) { 4085#if TCL_MAJOR_VERSION >= 8 4086 if (Tcl_GetIndexFromObj(interp, objv[1], (CONST84 char **)updateOptions, 4087 "option", 0, &optionIndex) != TCL_OK) { 4088 return TCL_ERROR; 4089 } 4090 switch ((enum updateOptions) optionIndex) { 4091 case REGEXP_IDLETASKS: { 4092 flags = TCL_IDLE_EVENTS; 4093 break; 4094 } 4095 default: { 4096 rb_bug("ip_rb_threadUpdateObjCmd: bad option index to UpdateOptions"); 4097 } 4098 } 4099#else 4100 if (strncmp(objv[1], "idletasks", strlen(objv[1])) != 0) { 4101 Tcl_AppendResult(interp, "bad option \"", objv[1], 4102 "\": must be idletasks", (char *) NULL); 4103 return TCL_ERROR; 4104 } 4105 flags = TCL_IDLE_EVENTS; 4106#endif 4107 } else { 4108#ifdef Tcl_WrongNumArgs 4109 Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]"); 4110#else 4111# if TCL_MAJOR_VERSION >= 8 4112 int dummy; 4113 Tcl_AppendResult(interp, "wrong number of arguments: should be \"", 4114 Tcl_GetStringFromObj(objv[0], &dummy), 4115 " [ idletasks ]\"", 4116 (char *) NULL); 4117# else /* TCL_MAJOR_VERSION < 8 */ 4118 Tcl_AppendResult(interp, "wrong number of arguments: should be \"", 4119 objv[0], " [ idletasks ]\"", (char *) NULL); 4120# endif 4121#endif 4122 return TCL_ERROR; 4123 } 4124 4125 DUMP1("pass argument check"); 4126 4127 /* param = (struct th_update_param *)Tcl_Alloc(sizeof(struct th_update_param)); */ 4128 param = RbTk_ALLOC_N(struct th_update_param, 1); 4129#if 0 /* use Tcl_Preserve/Release */ 4130 Tcl_Preserve((ClientData)param); 4131#endif 4132 param->thread = current_thread; 4133 param->done = 0; 4134 4135 DUMP1("set idle proc"); 4136 Tcl_DoWhenIdle(rb_threadUpdateProc, (ClientData) param); 4137 4138 t.tv_sec = 0; 4139 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0); 4140 4141 while(!param->done) { 4142 DUMP1("wait for complete idle proc"); 4143 /* rb_thread_stop(); */ 4144 /* rb_thread_sleep_forever(); */ 4145 rb_thread_wait_for(t); 4146 if (NIL_P(eventloop_thread)) { 4147 break; 4148 } 4149 } 4150 4151#if 0 /* use Tcl_EventuallyFree */ 4152 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ 4153#else 4154#if 0 /* use Tcl_Preserve/Release */ 4155 Tcl_Release((ClientData)param); 4156#else 4157 /* Tcl_Free((char *)param); */ 4158 ckfree((char *)param); 4159#endif 4160#endif 4161 4162 DUMP1("finish Ruby's 'thread_update'"); 4163 return TCL_OK; 4164} 4165 4166 4167/***************************/ 4168/* replace of vwait/tkwait */ 4169/***************************/ 4170#if TCL_MAJOR_VERSION >= 8 4171static int ip_rbVwaitObjCmd _((ClientData, Tcl_Interp *, int, 4172 Tcl_Obj *CONST [])); 4173static int ip_rb_threadVwaitObjCmd _((ClientData, Tcl_Interp *, int, 4174 Tcl_Obj *CONST [])); 4175static int ip_rbTkWaitObjCmd _((ClientData, Tcl_Interp *, int, 4176 Tcl_Obj *CONST [])); 4177static int ip_rb_threadTkWaitObjCmd _((ClientData, Tcl_Interp *, int, 4178 Tcl_Obj *CONST [])); 4179#else 4180static int ip_rbVwaitCommand _((ClientData, Tcl_Interp *, int, char *[])); 4181static int ip_rb_threadVwaitCommand _((ClientData, Tcl_Interp *, int, 4182 char *[])); 4183static int ip_rbTkWaitCommand _((ClientData, Tcl_Interp *, int, char *[])); 4184static int ip_rb_threadTkWaitCommand _((ClientData, Tcl_Interp *, int, 4185 char *[])); 4186#endif 4187 4188#if TCL_MAJOR_VERSION >= 8 4189static char *VwaitVarProc _((ClientData, Tcl_Interp *, 4190 CONST84 char *,CONST84 char *, int)); 4191static char * 4192VwaitVarProc(clientData, interp, name1, name2, flags) 4193 ClientData clientData; /* Pointer to integer to set to 1. */ 4194 Tcl_Interp *interp; /* Interpreter containing variable. */ 4195 CONST84 char *name1; /* Name of variable. */ 4196 CONST84 char *name2; /* Second part of variable name. */ 4197 int flags; /* Information about what happened. */ 4198#else /* TCL_MAJOR_VERSION < 8 */ 4199static char *VwaitVarProc _((ClientData, Tcl_Interp *, char *, char *, int)); 4200static char * 4201VwaitVarProc(clientData, interp, name1, name2, flags) 4202 ClientData clientData; /* Pointer to integer to set to 1. */ 4203 Tcl_Interp *interp; /* Interpreter containing variable. */ 4204 char *name1; /* Name of variable. */ 4205 char *name2; /* Second part of variable name. */ 4206 int flags; /* Information about what happened. */ 4207#endif 4208{ 4209 int *donePtr = (int *) clientData; 4210 4211 *donePtr = 1; 4212 return (char *) NULL; 4213} 4214 4215#if TCL_MAJOR_VERSION >= 8 4216static int 4217ip_rbVwaitObjCmd(clientData, interp, objc, objv) 4218 ClientData clientData; /* Not used */ 4219 Tcl_Interp *interp; 4220 int objc; 4221 Tcl_Obj *CONST objv[]; 4222#else /* TCL_MAJOR_VERSION < 8 */ 4223static int 4224ip_rbVwaitCommand(clientData, interp, objc, objv) 4225 ClientData clientData; /* Not used */ 4226 Tcl_Interp *interp; 4227 int objc; 4228 char *objv[]; 4229#endif 4230{ 4231 int ret, done, foundEvent; 4232 char *nameString; 4233 int dummy; 4234 int thr_crit_bup; 4235 4236 DUMP1("Ruby's 'vwait' is called"); 4237 if (interp == (Tcl_Interp*)NULL) { 4238 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, 4239 "IP is deleted"); 4240 return TCL_ERROR; 4241 } 4242 4243#if 0 4244 if (!rb_thread_alone() 4245 && eventloop_thread != Qnil 4246 && eventloop_thread != rb_thread_current()) { 4247#if TCL_MAJOR_VERSION >= 8 4248 DUMP1("call ip_rb_threadVwaitObjCmd"); 4249 return ip_rb_threadVwaitObjCmd(clientData, interp, objc, objv); 4250#else /* TCL_MAJOR_VERSION < 8 */ 4251 DUMP1("call ip_rb_threadVwaitCommand"); 4252 return ip_rb_threadVwaitCommand(clientData, interp, objc, objv); 4253#endif 4254 } 4255#endif 4256 4257 Tcl_Preserve(interp); 4258#ifdef HAVE_NATIVETHREAD 4259#ifndef RUBY_USE_NATIVE_THREAD 4260 if (!ruby_native_thread_p()) { 4261 rb_bug("cross-thread violation on ip_rbVwaitCommand()"); 4262 } 4263#endif 4264#endif 4265 4266 Tcl_ResetResult(interp); 4267 4268 if (objc != 2) { 4269#ifdef Tcl_WrongNumArgs 4270 Tcl_WrongNumArgs(interp, 1, objv, "name"); 4271#else 4272 thr_crit_bup = rb_thread_critical; 4273 rb_thread_critical = Qtrue; 4274 4275#if TCL_MAJOR_VERSION >= 8 4276 /* nameString = Tcl_GetString(objv[0]); */ 4277 nameString = Tcl_GetStringFromObj(objv[0], &dummy); 4278#else /* TCL_MAJOR_VERSION < 8 */ 4279 nameString = objv[0]; 4280#endif 4281 Tcl_AppendResult(interp, "wrong number of arguments: should be \"", 4282 nameString, " name\"", (char *) NULL); 4283 4284 rb_thread_critical = thr_crit_bup; 4285#endif 4286 4287 Tcl_Release(interp); 4288 return TCL_ERROR; 4289 } 4290 4291 thr_crit_bup = rb_thread_critical; 4292 rb_thread_critical = Qtrue; 4293 4294#if TCL_MAJOR_VERSION >= 8 4295 Tcl_IncrRefCount(objv[1]); 4296 /* nameString = Tcl_GetString(objv[1]); */ 4297 nameString = Tcl_GetStringFromObj(objv[1], &dummy); 4298#else /* TCL_MAJOR_VERSION < 8 */ 4299 nameString = objv[1]; 4300#endif 4301 4302 /* 4303 if (Tcl_TraceVar(interp, nameString, 4304 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, 4305 VwaitVarProc, (ClientData) &done) != TCL_OK) { 4306 return TCL_ERROR; 4307 } 4308 */ 4309 ret = Tcl_TraceVar(interp, nameString, 4310 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, 4311 VwaitVarProc, (ClientData) &done); 4312 4313 rb_thread_critical = thr_crit_bup; 4314 4315 if (ret != TCL_OK) { 4316#if TCL_MAJOR_VERSION >= 8 4317 Tcl_DecrRefCount(objv[1]); 4318#endif 4319 Tcl_Release(interp); 4320 return TCL_ERROR; 4321 } 4322 4323 done = 0; 4324 4325 foundEvent = RTEST(lib_eventloop_launcher(/* not check root-widget */0, 4326 0, &done, interp)); 4327 4328 thr_crit_bup = rb_thread_critical; 4329 rb_thread_critical = Qtrue; 4330 4331 Tcl_UntraceVar(interp, nameString, 4332 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, 4333 VwaitVarProc, (ClientData) &done); 4334 4335 rb_thread_critical = thr_crit_bup; 4336 4337 /* exception check */ 4338 if (!NIL_P(rbtk_pending_exception)) { 4339#if TCL_MAJOR_VERSION >= 8 4340 Tcl_DecrRefCount(objv[1]); 4341#endif 4342 Tcl_Release(interp); 4343 4344/* 4345 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) { 4346*/ 4347 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit) 4348 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) { 4349 return TCL_RETURN; 4350 } else{ 4351 return TCL_ERROR; 4352 } 4353 } 4354 4355 /* trap check */ 4356#ifdef RUBY_VM 4357 if (rb_thread_check_trap_pending()) { 4358#else 4359 if (rb_trap_pending) { 4360#endif 4361#if TCL_MAJOR_VERSION >= 8 4362 Tcl_DecrRefCount(objv[1]); 4363#endif 4364 Tcl_Release(interp); 4365 4366 return TCL_RETURN; 4367 } 4368 4369 /* 4370 * Clear out the interpreter's result, since it may have been set 4371 * by event handlers. 4372 */ 4373 4374 Tcl_ResetResult(interp); 4375 if (!foundEvent) { 4376 thr_crit_bup = rb_thread_critical; 4377 rb_thread_critical = Qtrue; 4378 4379 Tcl_AppendResult(interp, "can't wait for variable \"", nameString, 4380 "\": would wait forever", (char *) NULL); 4381 4382 rb_thread_critical = thr_crit_bup; 4383 4384#if TCL_MAJOR_VERSION >= 8 4385 Tcl_DecrRefCount(objv[1]); 4386#endif 4387 Tcl_Release(interp); 4388 return TCL_ERROR; 4389 } 4390 4391#if TCL_MAJOR_VERSION >= 8 4392 Tcl_DecrRefCount(objv[1]); 4393#endif 4394 Tcl_Release(interp); 4395 return TCL_OK; 4396} 4397 4398 4399/**************************/ 4400/* based on tkCmd.c */ 4401/**************************/ 4402#if TCL_MAJOR_VERSION >= 8 4403static char *WaitVariableProc _((ClientData, Tcl_Interp *, 4404 CONST84 char *,CONST84 char *, int)); 4405static char * 4406WaitVariableProc(clientData, interp, name1, name2, flags) 4407 ClientData clientData; /* Pointer to integer to set to 1. */ 4408 Tcl_Interp *interp; /* Interpreter containing variable. */ 4409 CONST84 char *name1; /* Name of variable. */ 4410 CONST84 char *name2; /* Second part of variable name. */ 4411 int flags; /* Information about what happened. */ 4412#else /* TCL_MAJOR_VERSION < 8 */ 4413static char *WaitVariableProc _((ClientData, Tcl_Interp *, 4414 char *, char *, int)); 4415static char * 4416WaitVariableProc(clientData, interp, name1, name2, flags) 4417 ClientData clientData; /* Pointer to integer to set to 1. */ 4418 Tcl_Interp *interp; /* Interpreter containing variable. */ 4419 char *name1; /* Name of variable. */ 4420 char *name2; /* Second part of variable name. */ 4421 int flags; /* Information about what happened. */ 4422#endif 4423{ 4424 int *donePtr = (int *) clientData; 4425 4426 *donePtr = 1; 4427 return (char *) NULL; 4428} 4429 4430static void WaitVisibilityProc _((ClientData, XEvent *)); 4431static void 4432WaitVisibilityProc(clientData, eventPtr) 4433 ClientData clientData; /* Pointer to integer to set to 1. */ 4434 XEvent *eventPtr; /* Information about event (not used). */ 4435{ 4436 int *donePtr = (int *) clientData; 4437 4438 if (eventPtr->type == VisibilityNotify) { 4439 *donePtr = 1; 4440 } 4441 if (eventPtr->type == DestroyNotify) { 4442 *donePtr = 2; 4443 } 4444} 4445 4446static void WaitWindowProc _((ClientData, XEvent *)); 4447static void 4448WaitWindowProc(clientData, eventPtr) 4449 ClientData clientData; /* Pointer to integer to set to 1. */ 4450 XEvent *eventPtr; /* Information about event. */ 4451{ 4452 int *donePtr = (int *) clientData; 4453 4454 if (eventPtr->type == DestroyNotify) { 4455 *donePtr = 1; 4456 } 4457} 4458 4459#if TCL_MAJOR_VERSION >= 8 4460static int 4461ip_rbTkWaitObjCmd(clientData, interp, objc, objv) 4462 ClientData clientData; 4463 Tcl_Interp *interp; 4464 int objc; 4465 Tcl_Obj *CONST objv[]; 4466#else /* TCL_MAJOR_VERSION < 8 */ 4467static int 4468ip_rbTkWaitCommand(clientData, interp, objc, objv) 4469 ClientData clientData; 4470 Tcl_Interp *interp; 4471 int objc; 4472 char *objv[]; 4473#endif 4474{ 4475 Tk_Window tkwin = (Tk_Window) clientData; 4476 Tk_Window window; 4477 int done, index; 4478 static CONST char *optionStrings[] = { "variable", "visibility", "window", 4479 (char *) NULL }; 4480 enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW }; 4481 char *nameString; 4482 int ret, dummy; 4483 int thr_crit_bup; 4484 4485 DUMP1("Ruby's 'tkwait' is called"); 4486 if (interp == (Tcl_Interp*)NULL) { 4487 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, 4488 "IP is deleted"); 4489 return TCL_ERROR; 4490 } 4491 4492#if 0 4493 if (!rb_thread_alone() 4494 && eventloop_thread != Qnil 4495 && eventloop_thread != rb_thread_current()) { 4496#if TCL_MAJOR_VERSION >= 8 4497 DUMP1("call ip_rb_threadTkWaitObjCmd"); 4498 return ip_rb_threadTkWaitObjCmd((ClientData)tkwin, interp, objc, objv); 4499#else /* TCL_MAJOR_VERSION < 8 */ 4500 DUMP1("call ip_rb_threadTkWaitCommand"); 4501 return ip_rb_threadTkWwaitCommand((ClientData)tkwin, interp, objc, objv); 4502#endif 4503 } 4504#endif 4505 4506 Tcl_Preserve(interp); 4507 Tcl_ResetResult(interp); 4508 4509 if (objc != 3) { 4510#ifdef Tcl_WrongNumArgs 4511 Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name"); 4512#else 4513 thr_crit_bup = rb_thread_critical; 4514 rb_thread_critical = Qtrue; 4515 4516#if TCL_MAJOR_VERSION >= 8 4517 Tcl_AppendResult(interp, "wrong number of arguments: should be \"", 4518 Tcl_GetStringFromObj(objv[0], &dummy), 4519 " variable|visibility|window name\"", 4520 (char *) NULL); 4521#else /* TCL_MAJOR_VERSION < 8 */ 4522 Tcl_AppendResult(interp, "wrong number of arguments: should be \"", 4523 objv[0], " variable|visibility|window name\"", 4524 (char *) NULL); 4525#endif 4526 4527 rb_thread_critical = thr_crit_bup; 4528#endif 4529 4530 Tcl_Release(interp); 4531 return TCL_ERROR; 4532 } 4533 4534#if TCL_MAJOR_VERSION >= 8 4535 thr_crit_bup = rb_thread_critical; 4536 rb_thread_critical = Qtrue; 4537 4538 /* 4539 if (Tcl_GetIndexFromObj(interp, objv[1], 4540 (CONST84 char **)optionStrings, 4541 "option", 0, &index) != TCL_OK) { 4542 return TCL_ERROR; 4543 } 4544 */ 4545 ret = Tcl_GetIndexFromObj(interp, objv[1], 4546 (CONST84 char **)optionStrings, 4547 "option", 0, &index); 4548 4549 rb_thread_critical = thr_crit_bup; 4550 4551 if (ret != TCL_OK) { 4552 Tcl_Release(interp); 4553 return TCL_ERROR; 4554 } 4555#else /* TCL_MAJOR_VERSION < 8 */ 4556 { 4557 int c = objv[1][0]; 4558 size_t length = strlen(objv[1]); 4559 4560 if ((c == 'v') && (strncmp(objv[1], "variable", length) == 0) 4561 && (length >= 2)) { 4562 index = TKWAIT_VARIABLE; 4563 } else if ((c == 'v') && (strncmp(objv[1], "visibility", length) == 0) 4564 && (length >= 2)) { 4565 index = TKWAIT_VISIBILITY; 4566 } else if ((c == 'w') && (strncmp(objv[1], "window", length) == 0)) { 4567 index = TKWAIT_WINDOW; 4568 } else { 4569 Tcl_AppendResult(interp, "bad option \"", objv[1], 4570 "\": must be variable, visibility, or window", 4571 (char *) NULL); 4572 Tcl_Release(interp); 4573 return TCL_ERROR; 4574 } 4575 } 4576#endif 4577 4578 thr_crit_bup = rb_thread_critical; 4579 rb_thread_critical = Qtrue; 4580 4581#if TCL_MAJOR_VERSION >= 8 4582 Tcl_IncrRefCount(objv[2]); 4583 /* nameString = Tcl_GetString(objv[2]); */ 4584 nameString = Tcl_GetStringFromObj(objv[2], &dummy); 4585#else /* TCL_MAJOR_VERSION < 8 */ 4586 nameString = objv[2]; 4587#endif 4588 4589 rb_thread_critical = thr_crit_bup; 4590 4591 switch ((enum options) index) { 4592 case TKWAIT_VARIABLE: 4593 thr_crit_bup = rb_thread_critical; 4594 rb_thread_critical = Qtrue; 4595 /* 4596 if (Tcl_TraceVar(interp, nameString, 4597 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, 4598 WaitVariableProc, (ClientData) &done) != TCL_OK) { 4599 return TCL_ERROR; 4600 } 4601 */ 4602 ret = Tcl_TraceVar(interp, nameString, 4603 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, 4604 WaitVariableProc, (ClientData) &done); 4605 4606 rb_thread_critical = thr_crit_bup; 4607 4608 if (ret != TCL_OK) { 4609#if TCL_MAJOR_VERSION >= 8 4610 Tcl_DecrRefCount(objv[2]); 4611#endif 4612 Tcl_Release(interp); 4613 return TCL_ERROR; 4614 } 4615 4616 done = 0; 4617 /* lib_eventloop_core(check_rootwidget_flag, 0, &done); */ 4618 lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp); 4619 4620 thr_crit_bup = rb_thread_critical; 4621 rb_thread_critical = Qtrue; 4622 4623 Tcl_UntraceVar(interp, nameString, 4624 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, 4625 WaitVariableProc, (ClientData) &done); 4626 4627#if TCL_MAJOR_VERSION >= 8 4628 Tcl_DecrRefCount(objv[2]); 4629#endif 4630 4631 rb_thread_critical = thr_crit_bup; 4632 4633 /* exception check */ 4634 if (!NIL_P(rbtk_pending_exception)) { 4635 Tcl_Release(interp); 4636 4637 /* 4638 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) { 4639 */ 4640 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit) 4641 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) { 4642 return TCL_RETURN; 4643 } else{ 4644 return TCL_ERROR; 4645 } 4646 } 4647 4648 /* trap check */ 4649#ifdef RUBY_VM 4650 if (rb_thread_check_trap_pending()) { 4651#else 4652 if (rb_trap_pending) { 4653#endif 4654 Tcl_Release(interp); 4655 4656 return TCL_RETURN; 4657 } 4658 4659 break; 4660 4661 case TKWAIT_VISIBILITY: 4662 thr_crit_bup = rb_thread_critical; 4663 rb_thread_critical = Qtrue; 4664 4665 /* This function works on the Tk eventloop thread only. */ 4666 if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) { 4667 window = NULL; 4668 } else { 4669 window = Tk_NameToWindow(interp, nameString, tkwin); 4670 } 4671 4672 if (window == NULL) { 4673 Tcl_AppendResult(interp, ": tkwait: ", 4674 "no main-window (not Tk application?)", 4675 (char*)NULL); 4676 rb_thread_critical = thr_crit_bup; 4677#if TCL_MAJOR_VERSION >= 8 4678 Tcl_DecrRefCount(objv[2]); 4679#endif 4680 Tcl_Release(interp); 4681 return TCL_ERROR; 4682 } 4683 4684 Tk_CreateEventHandler(window, 4685 VisibilityChangeMask|StructureNotifyMask, 4686 WaitVisibilityProc, (ClientData) &done); 4687 4688 rb_thread_critical = thr_crit_bup; 4689 4690 done = 0; 4691 /* lib_eventloop_core(check_rootwidget_flag, 0, &done); */ 4692 lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp); 4693 4694 /* exception check */ 4695 if (!NIL_P(rbtk_pending_exception)) { 4696#if TCL_MAJOR_VERSION >= 8 4697 Tcl_DecrRefCount(objv[2]); 4698#endif 4699 Tcl_Release(interp); 4700 4701 /* 4702 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) { 4703 */ 4704 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit) 4705 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) { 4706 return TCL_RETURN; 4707 } else{ 4708 return TCL_ERROR; 4709 } 4710 } 4711 4712 /* trap check */ 4713#ifdef RUBY_VM 4714 if (rb_thread_check_trap_pending()) { 4715#else 4716 if (rb_trap_pending) { 4717#endif 4718#if TCL_MAJOR_VERSION >= 8 4719 Tcl_DecrRefCount(objv[2]); 4720#endif 4721 Tcl_Release(interp); 4722 4723 return TCL_RETURN; 4724 } 4725 4726 if (done != 1) { 4727 /* 4728 * Note that we do not delete the event handler because it 4729 * was deleted automatically when the window was destroyed. 4730 */ 4731 thr_crit_bup = rb_thread_critical; 4732 rb_thread_critical = Qtrue; 4733 4734 Tcl_ResetResult(interp); 4735 Tcl_AppendResult(interp, "window \"", nameString, 4736 "\" was deleted before its visibility changed", 4737 (char *) NULL); 4738 4739 rb_thread_critical = thr_crit_bup; 4740 4741#if TCL_MAJOR_VERSION >= 8 4742 Tcl_DecrRefCount(objv[2]); 4743#endif 4744 Tcl_Release(interp); 4745 return TCL_ERROR; 4746 } 4747 4748 thr_crit_bup = rb_thread_critical; 4749 rb_thread_critical = Qtrue; 4750 4751#if TCL_MAJOR_VERSION >= 8 4752 Tcl_DecrRefCount(objv[2]); 4753#endif 4754 4755 Tk_DeleteEventHandler(window, 4756 VisibilityChangeMask|StructureNotifyMask, 4757 WaitVisibilityProc, (ClientData) &done); 4758 4759 rb_thread_critical = thr_crit_bup; 4760 4761 break; 4762 4763 case TKWAIT_WINDOW: 4764 thr_crit_bup = rb_thread_critical; 4765 rb_thread_critical = Qtrue; 4766 4767 /* This function works on the Tk eventloop thread only. */ 4768 if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) { 4769 window = NULL; 4770 } else { 4771 window = Tk_NameToWindow(interp, nameString, tkwin); 4772 } 4773 4774#if TCL_MAJOR_VERSION >= 8 4775 Tcl_DecrRefCount(objv[2]); 4776#endif 4777 4778 if (window == NULL) { 4779 Tcl_AppendResult(interp, ": tkwait: ", 4780 "no main-window (not Tk application?)", 4781 (char*)NULL); 4782 rb_thread_critical = thr_crit_bup; 4783 Tcl_Release(interp); 4784 return TCL_ERROR; 4785 } 4786 4787 Tk_CreateEventHandler(window, StructureNotifyMask, 4788 WaitWindowProc, (ClientData) &done); 4789 4790 rb_thread_critical = thr_crit_bup; 4791 4792 done = 0; 4793 /* lib_eventloop_core(check_rootwidget_flag, 0, &done); */ 4794 lib_eventloop_launcher(check_rootwidget_flag, 0, &done, interp); 4795 4796 /* exception check */ 4797 if (!NIL_P(rbtk_pending_exception)) { 4798 Tcl_Release(interp); 4799 4800 /* 4801 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit)) { 4802 */ 4803 if (rb_obj_is_kind_of(rbtk_pending_exception, rb_eSystemExit) 4804 || rb_obj_is_kind_of(rbtk_pending_exception, rb_eInterrupt)) { 4805 return TCL_RETURN; 4806 } else{ 4807 return TCL_ERROR; 4808 } 4809 } 4810 4811 /* trap check */ 4812#ifdef RUBY_VM 4813 if (rb_thread_check_trap_pending()) { 4814#else 4815 if (rb_trap_pending) { 4816#endif 4817 Tcl_Release(interp); 4818 4819 return TCL_RETURN; 4820 } 4821 4822 /* 4823 * Note: there's no need to delete the event handler. It was 4824 * deleted automatically when the window was destroyed. 4825 */ 4826 break; 4827 } 4828 4829 /* 4830 * Clear out the interpreter's result, since it may have been set 4831 * by event handlers. 4832 */ 4833 4834 Tcl_ResetResult(interp); 4835 Tcl_Release(interp); 4836 return TCL_OK; 4837} 4838 4839/****************************/ 4840/* vwait/tkwait with thread */ 4841/****************************/ 4842struct th_vwait_param { 4843 VALUE thread; 4844 int done; 4845}; 4846 4847#if TCL_MAJOR_VERSION >= 8 4848static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *, 4849 CONST84 char *,CONST84 char *, int)); 4850static char * 4851rb_threadVwaitProc(clientData, interp, name1, name2, flags) 4852 ClientData clientData; /* Pointer to integer to set to 1. */ 4853 Tcl_Interp *interp; /* Interpreter containing variable. */ 4854 CONST84 char *name1; /* Name of variable. */ 4855 CONST84 char *name2; /* Second part of variable name. */ 4856 int flags; /* Information about what happened. */ 4857#else /* TCL_MAJOR_VERSION < 8 */ 4858static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *, 4859 char *, char *, int)); 4860static char * 4861rb_threadVwaitProc(clientData, interp, name1, name2, flags) 4862 ClientData clientData; /* Pointer to integer to set to 1. */ 4863 Tcl_Interp *interp; /* Interpreter containing variable. */ 4864 char *name1; /* Name of variable. */ 4865 char *name2; /* Second part of variable name. */ 4866 int flags; /* Information about what happened. */ 4867#endif 4868{ 4869 struct th_vwait_param *param = (struct th_vwait_param *) clientData; 4870 4871 if (flags & (TCL_INTERP_DESTROYED | TCL_TRACE_DESTROYED)) { 4872 param->done = -1; 4873 } else { 4874 param->done = 1; 4875 } 4876 if (param->done != 0) rb_thread_wakeup(param->thread); 4877 4878 return (char *)NULL; 4879} 4880 4881#define TKWAIT_MODE_VISIBILITY 1 4882#define TKWAIT_MODE_DESTROY 2 4883 4884static void rb_threadWaitVisibilityProc _((ClientData, XEvent *)); 4885static void 4886rb_threadWaitVisibilityProc(clientData, eventPtr) 4887 ClientData clientData; /* Pointer to integer to set to 1. */ 4888 XEvent *eventPtr; /* Information about event (not used). */ 4889{ 4890 struct th_vwait_param *param = (struct th_vwait_param *) clientData; 4891 4892 if (eventPtr->type == VisibilityNotify) { 4893 param->done = TKWAIT_MODE_VISIBILITY; 4894 } 4895 if (eventPtr->type == DestroyNotify) { 4896 param->done = TKWAIT_MODE_DESTROY; 4897 } 4898 if (param->done != 0) rb_thread_wakeup(param->thread); 4899} 4900 4901static void rb_threadWaitWindowProc _((ClientData, XEvent *)); 4902static void 4903rb_threadWaitWindowProc(clientData, eventPtr) 4904 ClientData clientData; /* Pointer to integer to set to 1. */ 4905 XEvent *eventPtr; /* Information about event. */ 4906{ 4907 struct th_vwait_param *param = (struct th_vwait_param *) clientData; 4908 4909 if (eventPtr->type == DestroyNotify) { 4910 param->done = TKWAIT_MODE_DESTROY; 4911 } 4912 if (param->done != 0) rb_thread_wakeup(param->thread); 4913} 4914 4915#if TCL_MAJOR_VERSION >= 8 4916static int 4917ip_rb_threadVwaitObjCmd(clientData, interp, objc, objv) 4918 ClientData clientData; 4919 Tcl_Interp *interp; 4920 int objc; 4921 Tcl_Obj *CONST objv[]; 4922#else /* TCL_MAJOR_VERSION < 8 */ 4923static int 4924ip_rb_threadVwaitCommand(clientData, interp, objc, objv) 4925 ClientData clientData; /* Not used */ 4926 Tcl_Interp *interp; 4927 int objc; 4928 char *objv[]; 4929#endif 4930{ 4931 struct th_vwait_param *param; 4932 char *nameString; 4933 int ret, dummy; 4934 int thr_crit_bup; 4935 volatile VALUE current_thread = rb_thread_current(); 4936 struct timeval t; 4937 4938 DUMP1("Ruby's 'thread_vwait' is called"); 4939 if (interp == (Tcl_Interp*)NULL) { 4940 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, 4941 "IP is deleted"); 4942 return TCL_ERROR; 4943 } 4944 4945 if (rb_thread_alone() || eventloop_thread == current_thread) { 4946#if TCL_MAJOR_VERSION >= 8 4947 DUMP1("call ip_rbVwaitObjCmd"); 4948 return ip_rbVwaitObjCmd(clientData, interp, objc, objv); 4949#else /* TCL_MAJOR_VERSION < 8 */ 4950 DUMP1("call ip_rbVwaitCommand"); 4951 return ip_rbVwaitCommand(clientData, interp, objc, objv); 4952#endif 4953 } 4954 4955 Tcl_Preserve(interp); 4956 Tcl_ResetResult(interp); 4957 4958 if (objc != 2) { 4959#ifdef Tcl_WrongNumArgs 4960 Tcl_WrongNumArgs(interp, 1, objv, "name"); 4961#else 4962 thr_crit_bup = rb_thread_critical; 4963 rb_thread_critical = Qtrue; 4964 4965#if TCL_MAJOR_VERSION >= 8 4966 /* nameString = Tcl_GetString(objv[0]); */ 4967 nameString = Tcl_GetStringFromObj(objv[0], &dummy); 4968#else /* TCL_MAJOR_VERSION < 8 */ 4969 nameString = objv[0]; 4970#endif 4971 Tcl_AppendResult(interp, "wrong number of arguments: should be \"", 4972 nameString, " name\"", (char *) NULL); 4973 4974 rb_thread_critical = thr_crit_bup; 4975#endif 4976 4977 Tcl_Release(interp); 4978 return TCL_ERROR; 4979 } 4980 4981#if TCL_MAJOR_VERSION >= 8 4982 Tcl_IncrRefCount(objv[1]); 4983 /* nameString = Tcl_GetString(objv[1]); */ 4984 nameString = Tcl_GetStringFromObj(objv[1], &dummy); 4985#else /* TCL_MAJOR_VERSION < 8 */ 4986 nameString = objv[1]; 4987#endif 4988 thr_crit_bup = rb_thread_critical; 4989 rb_thread_critical = Qtrue; 4990 4991 /* param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); */ 4992 param = RbTk_ALLOC_N(struct th_vwait_param, 1); 4993#if 1 /* use Tcl_Preserve/Release */ 4994 Tcl_Preserve((ClientData)param); 4995#endif 4996 param->thread = current_thread; 4997 param->done = 0; 4998 4999 /* 5000 if (Tcl_TraceVar(interp, nameString, 5001 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, 5002 rb_threadVwaitProc, (ClientData) param) != TCL_OK) { 5003 return TCL_ERROR; 5004 } 5005 */ 5006 ret = Tcl_TraceVar(interp, nameString, 5007 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, 5008 rb_threadVwaitProc, (ClientData) param); 5009 5010 rb_thread_critical = thr_crit_bup; 5011 5012 if (ret != TCL_OK) { 5013#if 0 /* use Tcl_EventuallyFree */ 5014 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ 5015#else 5016#if 1 /* use Tcl_Preserve/Release */ 5017 Tcl_Release((ClientData)param); 5018#else 5019 /* Tcl_Free((char *)param); */ 5020 ckfree((char *)param); 5021#endif 5022#endif 5023 5024#if TCL_MAJOR_VERSION >= 8 5025 Tcl_DecrRefCount(objv[1]); 5026#endif 5027 Tcl_Release(interp); 5028 return TCL_ERROR; 5029 } 5030 5031 t.tv_sec = 0; 5032 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0); 5033 5034 while(!param->done) { 5035 /* rb_thread_stop(); */ 5036 /* rb_thread_sleep_forever(); */ 5037 rb_thread_wait_for(t); 5038 if (NIL_P(eventloop_thread)) { 5039 break; 5040 } 5041 } 5042 5043 thr_crit_bup = rb_thread_critical; 5044 rb_thread_critical = Qtrue; 5045 5046 if (param->done > 0) { 5047 Tcl_UntraceVar(interp, nameString, 5048 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, 5049 rb_threadVwaitProc, (ClientData) param); 5050 } 5051 5052#if 0 /* use Tcl_EventuallyFree */ 5053 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ 5054#else 5055#if 1 /* use Tcl_Preserve/Release */ 5056 Tcl_Release((ClientData)param); 5057#else 5058 /* Tcl_Free((char *)param); */ 5059 ckfree((char *)param); 5060#endif 5061#endif 5062 5063 rb_thread_critical = thr_crit_bup; 5064 5065#if TCL_MAJOR_VERSION >= 8 5066 Tcl_DecrRefCount(objv[1]); 5067#endif 5068 Tcl_Release(interp); 5069 return TCL_OK; 5070} 5071 5072#if TCL_MAJOR_VERSION >= 8 5073static int 5074ip_rb_threadTkWaitObjCmd(clientData, interp, objc, objv) 5075 ClientData clientData; 5076 Tcl_Interp *interp; 5077 int objc; 5078 Tcl_Obj *CONST objv[]; 5079#else /* TCL_MAJOR_VERSION < 8 */ 5080static int 5081ip_rb_threadTkWaitCommand(clientData, interp, objc, objv) 5082 ClientData clientData; 5083 Tcl_Interp *interp; 5084 int objc; 5085 char *objv[]; 5086#endif 5087{ 5088 struct th_vwait_param *param; 5089 Tk_Window tkwin = (Tk_Window) clientData; 5090 Tk_Window window; 5091 int index; 5092 static CONST char *optionStrings[] = { "variable", "visibility", "window", 5093 (char *) NULL }; 5094 enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW }; 5095 char *nameString; 5096 int ret, dummy; 5097 int thr_crit_bup; 5098 volatile VALUE current_thread = rb_thread_current(); 5099 struct timeval t; 5100 5101 DUMP1("Ruby's 'thread_tkwait' is called"); 5102 if (interp == (Tcl_Interp*)NULL) { 5103 rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError, 5104 "IP is deleted"); 5105 return TCL_ERROR; 5106 } 5107 5108 if (rb_thread_alone() || eventloop_thread == current_thread) { 5109#if TCL_MAJOR_VERSION >= 8 5110 DUMP1("call ip_rbTkWaitObjCmd"); 5111 DUMP2("eventloop_thread %lx", eventloop_thread); 5112 DUMP2("current_thread %lx", current_thread); 5113 return ip_rbTkWaitObjCmd(clientData, interp, objc, objv); 5114#else /* TCL_MAJOR_VERSION < 8 */ 5115 DUMP1("call rb_VwaitCommand"); 5116 return ip_rbTkWaitCommand(clientData, interp, objc, objv); 5117#endif 5118 } 5119 5120 Tcl_Preserve(interp); 5121 Tcl_Preserve(tkwin); 5122 5123 Tcl_ResetResult(interp); 5124 5125 if (objc != 3) { 5126#ifdef Tcl_WrongNumArgs 5127 Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name"); 5128#else 5129 thr_crit_bup = rb_thread_critical; 5130 rb_thread_critical = Qtrue; 5131 5132#if TCL_MAJOR_VERSION >= 8 5133 Tcl_AppendResult(interp, "wrong number of arguments: should be \"", 5134 Tcl_GetStringFromObj(objv[0], &dummy), 5135 " variable|visibility|window name\"", 5136 (char *) NULL); 5137#else /* TCL_MAJOR_VERSION < 8 */ 5138 Tcl_AppendResult(interp, "wrong number of arguments: should be \"", 5139 objv[0], " variable|visibility|window name\"", 5140 (char *) NULL); 5141#endif 5142 5143 rb_thread_critical = thr_crit_bup; 5144#endif 5145 5146 Tcl_Release(tkwin); 5147 Tcl_Release(interp); 5148 return TCL_ERROR; 5149 } 5150 5151#if TCL_MAJOR_VERSION >= 8 5152 thr_crit_bup = rb_thread_critical; 5153 rb_thread_critical = Qtrue; 5154 /* 5155 if (Tcl_GetIndexFromObj(interp, objv[1], 5156 (CONST84 char **)optionStrings, 5157 "option", 0, &index) != TCL_OK) { 5158 return TCL_ERROR; 5159 } 5160 */ 5161 ret = Tcl_GetIndexFromObj(interp, objv[1], 5162 (CONST84 char **)optionStrings, 5163 "option", 0, &index); 5164 5165 rb_thread_critical = thr_crit_bup; 5166 5167 if (ret != TCL_OK) { 5168 Tcl_Release(tkwin); 5169 Tcl_Release(interp); 5170 return TCL_ERROR; 5171 } 5172#else /* TCL_MAJOR_VERSION < 8 */ 5173 { 5174 int c = objv[1][0]; 5175 size_t length = strlen(objv[1]); 5176 5177 if ((c == 'v') && (strncmp(objv[1], "variable", length) == 0) 5178 && (length >= 2)) { 5179 index = TKWAIT_VARIABLE; 5180 } else if ((c == 'v') && (strncmp(objv[1], "visibility", length) == 0) 5181 && (length >= 2)) { 5182 index = TKWAIT_VISIBILITY; 5183 } else if ((c == 'w') && (strncmp(objv[1], "window", length) == 0)) { 5184 index = TKWAIT_WINDOW; 5185 } else { 5186 Tcl_AppendResult(interp, "bad option \"", objv[1], 5187 "\": must be variable, visibility, or window", 5188 (char *) NULL); 5189 Tcl_Release(tkwin); 5190 Tcl_Release(interp); 5191 return TCL_ERROR; 5192 } 5193 } 5194#endif 5195 5196 thr_crit_bup = rb_thread_critical; 5197 rb_thread_critical = Qtrue; 5198 5199#if TCL_MAJOR_VERSION >= 8 5200 Tcl_IncrRefCount(objv[2]); 5201 /* nameString = Tcl_GetString(objv[2]); */ 5202 nameString = Tcl_GetStringFromObj(objv[2], &dummy); 5203#else /* TCL_MAJOR_VERSION < 8 */ 5204 nameString = objv[2]; 5205#endif 5206 5207 /* param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param)); */ 5208 param = RbTk_ALLOC_N(struct th_vwait_param, 1); 5209#if 1 /* use Tcl_Preserve/Release */ 5210 Tcl_Preserve((ClientData)param); 5211#endif 5212 param->thread = current_thread; 5213 param->done = 0; 5214 5215 rb_thread_critical = thr_crit_bup; 5216 5217 switch ((enum options) index) { 5218 case TKWAIT_VARIABLE: 5219 thr_crit_bup = rb_thread_critical; 5220 rb_thread_critical = Qtrue; 5221 /* 5222 if (Tcl_TraceVar(interp, nameString, 5223 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, 5224 rb_threadVwaitProc, (ClientData) param) != TCL_OK) { 5225 return TCL_ERROR; 5226 } 5227 */ 5228 ret = Tcl_TraceVar(interp, nameString, 5229 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, 5230 rb_threadVwaitProc, (ClientData) param); 5231 5232 rb_thread_critical = thr_crit_bup; 5233 5234 if (ret != TCL_OK) { 5235#if 0 /* use Tcl_EventuallyFree */ 5236 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ 5237#else 5238#if 1 /* use Tcl_Preserve/Release */ 5239 Tcl_Release(param); 5240#else 5241 /* Tcl_Free((char *)param); */ 5242 ckfree((char *)param); 5243#endif 5244#endif 5245 5246#if TCL_MAJOR_VERSION >= 8 5247 Tcl_DecrRefCount(objv[2]); 5248#endif 5249 5250 Tcl_Release(tkwin); 5251 Tcl_Release(interp); 5252 return TCL_ERROR; 5253 } 5254 5255 t.tv_sec = 0; 5256 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0); 5257 5258 while(!param->done) { 5259 /* rb_thread_stop(); */ 5260 /* rb_thread_sleep_forever(); */ 5261 rb_thread_wait_for(t); 5262 if (NIL_P(eventloop_thread)) { 5263 break; 5264 } 5265 } 5266 5267 thr_crit_bup = rb_thread_critical; 5268 rb_thread_critical = Qtrue; 5269 5270 if (param->done > 0) { 5271 Tcl_UntraceVar(interp, nameString, 5272 TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, 5273 rb_threadVwaitProc, (ClientData) param); 5274 } 5275 5276#if TCL_MAJOR_VERSION >= 8 5277 Tcl_DecrRefCount(objv[2]); 5278#endif 5279 5280 rb_thread_critical = thr_crit_bup; 5281 5282 break; 5283 5284 case TKWAIT_VISIBILITY: 5285 thr_crit_bup = rb_thread_critical; 5286 rb_thread_critical = Qtrue; 5287 5288#if 0 /* variable 'tkwin' must keep the token of MainWindow */ 5289 if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) { 5290 window = NULL; 5291 } else { 5292 window = Tk_NameToWindow(interp, nameString, tkwin); 5293 } 5294#else 5295 if (!tk_stubs_init_p() || tkwin == (Tk_Window)NULL) { 5296 window = NULL; 5297 } else { 5298 /* Tk_NameToWindow() returns right token on non-eventloop thread */ 5299 Tcl_CmdInfo info; 5300 if (Tcl_GetCommandInfo(interp, ".", &info)) { /* check root */ 5301 window = Tk_NameToWindow(interp, nameString, tkwin); 5302 } else { 5303 window = NULL; 5304 } 5305 } 5306#endif 5307 5308 if (window == NULL) { 5309 Tcl_AppendResult(interp, ": thread_tkwait: ", 5310 "no main-window (not Tk application?)", 5311 (char*)NULL); 5312 5313 rb_thread_critical = thr_crit_bup; 5314 5315#if 0 /* use Tcl_EventuallyFree */ 5316 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ 5317#else 5318#if 1 /* use Tcl_Preserve/Release */ 5319 Tcl_Release(param); 5320#else 5321 /* Tcl_Free((char *)param); */ 5322 ckfree((char *)param); 5323#endif 5324#endif 5325 5326#if TCL_MAJOR_VERSION >= 8 5327 Tcl_DecrRefCount(objv[2]); 5328#endif 5329 Tcl_Release(tkwin); 5330 Tcl_Release(interp); 5331 return TCL_ERROR; 5332 } 5333 Tcl_Preserve(window); 5334 5335 Tk_CreateEventHandler(window, 5336 VisibilityChangeMask|StructureNotifyMask, 5337 rb_threadWaitVisibilityProc, (ClientData) param); 5338 5339 rb_thread_critical = thr_crit_bup; 5340 5341 t.tv_sec = 0; 5342 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0); 5343 5344 while(param->done != TKWAIT_MODE_VISIBILITY) { 5345 if (param->done == TKWAIT_MODE_DESTROY) break; 5346 /* rb_thread_stop(); */ 5347 /* rb_thread_sleep_forever(); */ 5348 rb_thread_wait_for(t); 5349 if (NIL_P(eventloop_thread)) { 5350 break; 5351 } 5352 } 5353 5354 thr_crit_bup = rb_thread_critical; 5355 rb_thread_critical = Qtrue; 5356 5357 /* when a window is destroyed, no need to call Tk_DeleteEventHandler */ 5358 if (param->done != TKWAIT_MODE_DESTROY) { 5359 Tk_DeleteEventHandler(window, 5360 VisibilityChangeMask|StructureNotifyMask, 5361 rb_threadWaitVisibilityProc, 5362 (ClientData) param); 5363 } 5364 5365 if (param->done != 1) { 5366 Tcl_ResetResult(interp); 5367 Tcl_AppendResult(interp, "window \"", nameString, 5368 "\" was deleted before its visibility changed", 5369 (char *) NULL); 5370 5371 rb_thread_critical = thr_crit_bup; 5372 5373 Tcl_Release(window); 5374 5375#if 0 /* use Tcl_EventuallyFree */ 5376 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ 5377#else 5378#if 1 /* use Tcl_Preserve/Release */ 5379 Tcl_Release(param); 5380#else 5381 /* Tcl_Free((char *)param); */ 5382 ckfree((char *)param); 5383#endif 5384#endif 5385 5386#if TCL_MAJOR_VERSION >= 8 5387 Tcl_DecrRefCount(objv[2]); 5388#endif 5389 5390 Tcl_Release(tkwin); 5391 Tcl_Release(interp); 5392 return TCL_ERROR; 5393 } 5394 5395 Tcl_Release(window); 5396 5397#if TCL_MAJOR_VERSION >= 8 5398 Tcl_DecrRefCount(objv[2]); 5399#endif 5400 5401 rb_thread_critical = thr_crit_bup; 5402 5403 break; 5404 5405 case TKWAIT_WINDOW: 5406 thr_crit_bup = rb_thread_critical; 5407 rb_thread_critical = Qtrue; 5408 5409#if 0 /* variable 'tkwin' must keep the token of MainWindow */ 5410 if (!tk_stubs_init_p() || Tk_MainWindow(interp) == (Tk_Window)NULL) { 5411 window = NULL; 5412 } else { 5413 window = Tk_NameToWindow(interp, nameString, tkwin); 5414 } 5415#else 5416 if (!tk_stubs_init_p() || tkwin == (Tk_Window)NULL) { 5417 window = NULL; 5418 } else { 5419 /* Tk_NameToWindow() returns right token on non-eventloop thread */ 5420 Tcl_CmdInfo info; 5421 if (Tcl_GetCommandInfo(interp, ".", &info)) { /* check root */ 5422 window = Tk_NameToWindow(interp, nameString, tkwin); 5423 } else { 5424 window = NULL; 5425 } 5426 } 5427#endif 5428 5429#if TCL_MAJOR_VERSION >= 8 5430 Tcl_DecrRefCount(objv[2]); 5431#endif 5432 5433 if (window == NULL) { 5434 Tcl_AppendResult(interp, ": thread_tkwait: ", 5435 "no main-window (not Tk application?)", 5436 (char*)NULL); 5437 5438 rb_thread_critical = thr_crit_bup; 5439 5440#if 0 /* use Tcl_EventuallyFree */ 5441 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ 5442#else 5443#if 1 /* use Tcl_Preserve/Release */ 5444 Tcl_Release(param); 5445#else 5446 /* Tcl_Free((char *)param); */ 5447 ckfree((char *)param); 5448#endif 5449#endif 5450 5451 Tcl_Release(tkwin); 5452 Tcl_Release(interp); 5453 return TCL_ERROR; 5454 } 5455 5456 Tcl_Preserve(window); 5457 5458 Tk_CreateEventHandler(window, StructureNotifyMask, 5459 rb_threadWaitWindowProc, (ClientData) param); 5460 5461 rb_thread_critical = thr_crit_bup; 5462 5463 t.tv_sec = 0; 5464 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0); 5465 5466 while(param->done != TKWAIT_MODE_DESTROY) { 5467 /* rb_thread_stop(); */ 5468 /* rb_thread_sleep_forever(); */ 5469 rb_thread_wait_for(t); 5470 if (NIL_P(eventloop_thread)) { 5471 break; 5472 } 5473 } 5474 5475 Tcl_Release(window); 5476 5477 /* when a window is destroyed, no need to call Tk_DeleteEventHandler 5478 thr_crit_bup = rb_thread_critical; 5479 rb_thread_critical = Qtrue; 5480 5481 Tk_DeleteEventHandler(window, StructureNotifyMask, 5482 rb_threadWaitWindowProc, (ClientData) param); 5483 5484 rb_thread_critical = thr_crit_bup; 5485 */ 5486 5487 break; 5488 } /* end of 'switch' statement */ 5489 5490#if 0 /* use Tcl_EventuallyFree */ 5491 Tcl_EventuallyFree((ClientData)param, TCL_DYNAMIC); /* XXXXXXXX */ 5492#else 5493#if 1 /* use Tcl_Preserve/Release */ 5494 Tcl_Release((ClientData)param); 5495#else 5496 /* Tcl_Free((char *)param); */ 5497 ckfree((char *)param); 5498#endif 5499#endif 5500 5501 /* 5502 * Clear out the interpreter's result, since it may have been set 5503 * by event handlers. 5504 */ 5505 5506 Tcl_ResetResult(interp); 5507 5508 Tcl_Release(tkwin); 5509 Tcl_Release(interp); 5510 return TCL_OK; 5511} 5512 5513static VALUE 5514ip_thread_vwait(self, var) 5515 VALUE self; 5516 VALUE var; 5517{ 5518 VALUE argv[2]; 5519 volatile VALUE cmd_str = rb_str_new2("thread_vwait"); 5520 5521 argv[0] = cmd_str; 5522 argv[1] = var; 5523 5524 return ip_invoke_with_position(2, argv, self, TCL_QUEUE_TAIL); 5525} 5526 5527static VALUE 5528ip_thread_tkwait(self, mode, target) 5529 VALUE self; 5530 VALUE mode; 5531 VALUE target; 5532{ 5533 VALUE argv[3]; 5534 volatile VALUE cmd_str = rb_str_new2("thread_tkwait"); 5535 5536 argv[0] = cmd_str; 5537 argv[1] = mode; 5538 argv[2] = target; 5539 5540 return ip_invoke_with_position(3, argv, self, TCL_QUEUE_TAIL); 5541} 5542 5543 5544/* delete slave interpreters */ 5545#if TCL_MAJOR_VERSION >= 8 5546static void 5547delete_slaves(ip) 5548 Tcl_Interp *ip; 5549{ 5550 int thr_crit_bup; 5551 Tcl_Interp *slave; 5552 Tcl_Obj *slave_list, *elem; 5553 char *slave_name; 5554 int i, len; 5555 5556 DUMP1("delete slaves"); 5557 thr_crit_bup = rb_thread_critical; 5558 rb_thread_critical = Qtrue; 5559 5560 if (!Tcl_InterpDeleted(ip) && Tcl_Eval(ip, "interp slaves") == TCL_OK) { 5561 slave_list = Tcl_GetObjResult(ip); 5562 Tcl_IncrRefCount(slave_list); 5563 5564 if (Tcl_ListObjLength((Tcl_Interp*)NULL, slave_list, &len) == TCL_OK) { 5565 for(i = 0; i < len; i++) { 5566 Tcl_ListObjIndex((Tcl_Interp*)NULL, slave_list, i, &elem); 5567 5568 if (elem == (Tcl_Obj*)NULL) continue; 5569 5570 Tcl_IncrRefCount(elem); 5571 5572 /* get slave */ 5573 /* slave_name = Tcl_GetString(elem); */ 5574 slave_name = Tcl_GetStringFromObj(elem, (int*)NULL); 5575 DUMP2("delete slave:'%s'", slave_name); 5576 5577 Tcl_DecrRefCount(elem); 5578 5579 slave = Tcl_GetSlave(ip, slave_name); 5580 if (slave == (Tcl_Interp*)NULL) continue; 5581 5582 if (!Tcl_InterpDeleted(slave)) { 5583 /* call ip_finalize */ 5584 ip_finalize(slave); 5585 5586 Tcl_DeleteInterp(slave); 5587 /* Tcl_Release(slave); */ 5588 } 5589 } 5590 } 5591 5592 Tcl_DecrRefCount(slave_list); 5593 } 5594 5595 rb_thread_critical = thr_crit_bup; 5596} 5597#else /* TCL_MAJOR_VERSION < 8 */ 5598static void 5599delete_slaves(ip) 5600 Tcl_Interp *ip; 5601{ 5602 int thr_crit_bup; 5603 Tcl_Interp *slave; 5604 int argc; 5605 char **argv; 5606 char *slave_list; 5607 char *slave_name; 5608 int i, len; 5609 5610 DUMP1("delete slaves"); 5611 thr_crit_bup = rb_thread_critical; 5612 rb_thread_critical = Qtrue; 5613 5614 if (!Tcl_InterpDeleted(ip) && Tcl_Eval(ip, "interp slaves") == TCL_OK) { 5615 slave_list = ip->result; 5616 if (Tcl_SplitList((Tcl_Interp*)NULL, 5617 slave_list, &argc, &argv) == TCL_OK) { 5618 for(i = 0; i < argc; i++) { 5619 slave_name = argv[i]; 5620 5621 DUMP2("delete slave:'%s'", slave_name); 5622 5623 slave = Tcl_GetSlave(ip, slave_name); 5624 if (slave == (Tcl_Interp*)NULL) continue; 5625 5626 if (!Tcl_InterpDeleted(slave)) { 5627 /* call ip_finalize */ 5628 ip_finalize(slave); 5629 5630 Tcl_DeleteInterp(slave); 5631 } 5632 } 5633 } 5634 } 5635 5636 rb_thread_critical = thr_crit_bup; 5637} 5638#endif 5639 5640 5641/* finalize operation */ 5642static void 5643#ifdef HAVE_PROTOTYPES 5644lib_mark_at_exit(VALUE self) 5645#else 5646lib_mark_at_exit(self) 5647 VALUE self; 5648#endif 5649{ 5650 at_exit = 1; 5651} 5652 5653static int 5654#if TCL_MAJOR_VERSION >= 8 5655#ifdef HAVE_PROTOTYPES 5656ip_null_proc(ClientData clientData, Tcl_Interp *interp, 5657 int argc, Tcl_Obj *CONST argv[]) 5658#else 5659ip_null_proc(clientData, interp, argc, argv) 5660 ClientData clientData; 5661 Tcl_Interp *interp; 5662 int argc; 5663 Tcl_Obj *CONST argv[]; 5664#endif 5665#else /* TCL_MAJOR_VERSION < 8 */ 5666#ifdef HAVE_PROTOTYPES 5667ip_null_proc(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[]) 5668#else 5669ip_null_proc(clientData, interp, argc, argv) 5670 ClientData clientData; 5671 Tcl_Interp *interp; 5672 int argc; 5673 char *argv[]; 5674#endif 5675#endif 5676{ 5677 Tcl_ResetResult(interp); 5678 return TCL_OK; 5679} 5680 5681static void 5682ip_finalize(ip) 5683 Tcl_Interp *ip; 5684{ 5685 Tcl_CmdInfo info; 5686 int thr_crit_bup; 5687 5688 VALUE rb_debug_bup, rb_verbose_bup; 5689 /* When ruby is exiting, printing debug messages in some callback 5690 operations from Tcl-IP sometimes cause SEGV. I don't know the 5691 reason. But I got SEGV when calling "rb_io_write(rb_stdout, ...)". 5692 So, in some part of this function, debug mode and verbose mode 5693 are disabled. If you know the reason, please fix it. 5694 -- Hidetoshi NAGAI (nagai@ai.kyutech.ac.jp) */ 5695 5696 DUMP1("start ip_finalize"); 5697 5698 if (ip == (Tcl_Interp*)NULL) { 5699 DUMP1("ip is NULL"); 5700 return; 5701 } 5702 5703 if (Tcl_InterpDeleted(ip)) { 5704 DUMP2("ip(%p) is already deleted", ip); 5705 return; 5706 } 5707 5708#if TCL_NAMESPACE_DEBUG 5709 if (ip_null_namespace(ip)) { 5710 DUMP2("ip(%p) has null namespace", ip); 5711 return; 5712 } 5713#endif 5714 5715 thr_crit_bup = rb_thread_critical; 5716 rb_thread_critical = Qtrue; 5717 5718 rb_debug_bup = ruby_debug; 5719 rb_verbose_bup = ruby_verbose; 5720 5721 Tcl_Preserve(ip); 5722 5723 /* delete slaves */ 5724 delete_slaves(ip); 5725 5726 /* shut off some connections from Tcl-proc to Ruby */ 5727 if (at_exit) { 5728 /* NOTE: Only when at exit. 5729 Because, ruby removes objects, which depends on the deleted 5730 interpreter, on some callback operations. 5731 It is important for GC. */ 5732#if TCL_MAJOR_VERSION >= 8 5733 Tcl_CreateObjCommand(ip, "ruby", ip_null_proc, 5734 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); 5735 Tcl_CreateObjCommand(ip, "ruby_eval", ip_null_proc, 5736 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); 5737 Tcl_CreateObjCommand(ip, "ruby_cmd", ip_null_proc, 5738 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); 5739#else /* TCL_MAJOR_VERSION < 8 */ 5740 Tcl_CreateCommand(ip, "ruby", ip_null_proc, 5741 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); 5742 Tcl_CreateCommand(ip, "ruby_eval", ip_null_proc, 5743 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); 5744 Tcl_CreateCommand(ip, "ruby_cmd", ip_null_proc, 5745 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); 5746#endif 5747 /* 5748 rb_thread_critical = thr_crit_bup; 5749 return; 5750 */ 5751 } 5752 5753 /* delete root widget */ 5754#ifdef RUBY_VM 5755 /* cause SEGV on Ruby 1.9 */ 5756#else 5757 DUMP1("check `destroy'"); 5758 if (Tcl_GetCommandInfo(ip, "destroy", &info)) { 5759 DUMP1("call `destroy .'"); 5760 Tcl_GlobalEval(ip, "catch {destroy .}"); 5761 } 5762#endif 5763#if 1 5764 DUMP1("destroy root widget"); 5765 if (tk_stubs_init_p() && Tk_MainWindow(ip) != (Tk_Window)NULL) { 5766 /* 5767 * On Ruby VM, this code piece may be not called, because 5768 * Tk_MainWindow() returns NULL on a native thread except 5769 * the thread which initialize Tk environment. 5770 * Of course, that is a problem. But maybe not so serious. 5771 * All widgets are destroyed when the Tcl interp is deleted. 5772 * At then, Ruby may raise exceptions on the delete hook 5773 * callbacks which registered for the deleted widgets, and 5774 * may fail to clear objects which depends on the widgets. 5775 * Although it is the problem, it is possibly avoidable by 5776 * rescuing exceptions and the finalize hook of the interp. 5777 */ 5778 Tk_Window win = Tk_MainWindow(ip); 5779 5780 DUMP1("call Tk_DestroyWindow"); 5781 ruby_debug = Qfalse; 5782 ruby_verbose = Qnil; 5783 if (! (((Tk_FakeWin*)win)->flags & TK_ALREADY_DEAD)) { 5784 Tk_DestroyWindow(win); 5785 } 5786 ruby_debug = rb_debug_bup; 5787 ruby_verbose = rb_verbose_bup; 5788 } 5789#endif 5790 5791 /* call finalize-hook-proc */ 5792 DUMP1("check `finalize-hook-proc'"); 5793 if ( Tcl_GetCommandInfo(ip, finalize_hook_name, &info)) { 5794 DUMP2("call finalize hook proc '%s'", finalize_hook_name); 5795 ruby_debug = Qfalse; 5796 ruby_verbose = Qnil; 5797 Tcl_GlobalEval(ip, finalize_hook_name); 5798 ruby_debug = rb_debug_bup; 5799 ruby_verbose = rb_verbose_bup; 5800 } 5801 5802 DUMP1("check `foreach' & `after'"); 5803 if ( Tcl_GetCommandInfo(ip, "foreach", &info) 5804 && Tcl_GetCommandInfo(ip, "after", &info) ) { 5805 DUMP1("cancel after callbacks"); 5806 ruby_debug = Qfalse; 5807 ruby_verbose = Qnil; 5808 Tcl_GlobalEval(ip, "catch {foreach id [after info] {after cancel $id}}"); 5809 ruby_debug = rb_debug_bup; 5810 ruby_verbose = rb_verbose_bup; 5811 } 5812 5813 Tcl_Release(ip); 5814 5815 DUMP1("finish ip_finalize"); 5816 ruby_debug = rb_debug_bup; 5817 ruby_verbose = rb_verbose_bup; 5818 rb_thread_critical = thr_crit_bup; 5819} 5820 5821 5822/* destroy interpreter */ 5823static void 5824ip_free(ptr) 5825 struct tcltkip *ptr; 5826{ 5827 int thr_crit_bup; 5828 5829 DUMP2("free Tcl Interp %lx", (unsigned long)ptr->ip); 5830 if (ptr) { 5831 thr_crit_bup = rb_thread_critical; 5832 rb_thread_critical = Qtrue; 5833 5834 if ( ptr->ip != (Tcl_Interp*)NULL 5835 && !Tcl_InterpDeleted(ptr->ip) 5836 && Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL 5837 && !Tcl_InterpDeleted(Tcl_GetMaster(ptr->ip)) ) { 5838 DUMP2("parent IP(%lx) is not deleted", 5839 (unsigned long)Tcl_GetMaster(ptr->ip)); 5840 DUMP2("slave IP(%lx) should not be deleted", 5841 (unsigned long)ptr->ip); 5842 xfree(ptr); 5843 /* ckfree((char*)ptr); */ 5844 rb_thread_critical = thr_crit_bup; 5845 return; 5846 } 5847 5848 if (ptr->ip == (Tcl_Interp*)NULL) { 5849 DUMP1("ip_free is called for deleted IP"); 5850 xfree(ptr); 5851 /* ckfree((char*)ptr); */ 5852 rb_thread_critical = thr_crit_bup; 5853 return; 5854 } 5855 5856 if (!Tcl_InterpDeleted(ptr->ip)) { 5857 ip_finalize(ptr->ip); 5858 5859 Tcl_DeleteInterp(ptr->ip); 5860 Tcl_Release(ptr->ip); 5861 } 5862 5863 ptr->ip = (Tcl_Interp*)NULL; 5864 xfree(ptr); 5865 /* ckfree((char*)ptr); */ 5866 5867 rb_thread_critical = thr_crit_bup; 5868 } 5869 5870 DUMP1("complete freeing Tcl Interp"); 5871} 5872 5873 5874/* create and initialize interpreter */ 5875static VALUE ip_alloc _((VALUE)); 5876static VALUE 5877ip_alloc(self) 5878 VALUE self; 5879{ 5880 return Data_Wrap_Struct(self, 0, ip_free, 0); 5881} 5882 5883static void 5884ip_replace_wait_commands(interp, mainWin) 5885 Tcl_Interp *interp; 5886 Tk_Window mainWin; 5887{ 5888 /* replace 'vwait' command */ 5889#if TCL_MAJOR_VERSION >= 8 5890 DUMP1("Tcl_CreateObjCommand(\"vwait\")"); 5891 Tcl_CreateObjCommand(interp, "vwait", ip_rbVwaitObjCmd, 5892 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); 5893#else /* TCL_MAJOR_VERSION < 8 */ 5894 DUMP1("Tcl_CreateCommand(\"vwait\")"); 5895 Tcl_CreateCommand(interp, "vwait", ip_rbVwaitCommand, 5896 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); 5897#endif 5898 5899 /* replace 'tkwait' command */ 5900#if TCL_MAJOR_VERSION >= 8 5901 DUMP1("Tcl_CreateObjCommand(\"tkwait\")"); 5902 Tcl_CreateObjCommand(interp, "tkwait", ip_rbTkWaitObjCmd, 5903 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 5904#else /* TCL_MAJOR_VERSION < 8 */ 5905 DUMP1("Tcl_CreateCommand(\"tkwait\")"); 5906 Tcl_CreateCommand(interp, "tkwait", ip_rbTkWaitCommand, 5907 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 5908#endif 5909 5910 /* add 'thread_vwait' command */ 5911#if TCL_MAJOR_VERSION >= 8 5912 DUMP1("Tcl_CreateObjCommand(\"thread_vwait\")"); 5913 Tcl_CreateObjCommand(interp, "thread_vwait", ip_rb_threadVwaitObjCmd, 5914 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); 5915#else /* TCL_MAJOR_VERSION < 8 */ 5916 DUMP1("Tcl_CreateCommand(\"thread_vwait\")"); 5917 Tcl_CreateCommand(interp, "thread_vwait", ip_rb_threadVwaitCommand, 5918 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); 5919#endif 5920 5921 /* add 'thread_tkwait' command */ 5922#if TCL_MAJOR_VERSION >= 8 5923 DUMP1("Tcl_CreateObjCommand(\"thread_tkwait\")"); 5924 Tcl_CreateObjCommand(interp, "thread_tkwait", ip_rb_threadTkWaitObjCmd, 5925 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 5926#else /* TCL_MAJOR_VERSION < 8 */ 5927 DUMP1("Tcl_CreateCommand(\"thread_tkwait\")"); 5928 Tcl_CreateCommand(interp, "thread_tkwait", ip_rb_threadTkWaitCommand, 5929 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 5930#endif 5931 5932 /* replace 'update' command */ 5933#if TCL_MAJOR_VERSION >= 8 5934 DUMP1("Tcl_CreateObjCommand(\"update\")"); 5935 Tcl_CreateObjCommand(interp, "update", ip_rbUpdateObjCmd, 5936 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 5937#else /* TCL_MAJOR_VERSION < 8 */ 5938 DUMP1("Tcl_CreateCommand(\"update\")"); 5939 Tcl_CreateCommand(interp, "update", ip_rbUpdateCommand, 5940 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 5941#endif 5942 5943 /* add 'thread_update' command */ 5944#if TCL_MAJOR_VERSION >= 8 5945 DUMP1("Tcl_CreateObjCommand(\"thread_update\")"); 5946 Tcl_CreateObjCommand(interp, "thread_update", ip_rb_threadUpdateObjCmd, 5947 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 5948#else /* TCL_MAJOR_VERSION < 8 */ 5949 DUMP1("Tcl_CreateCommand(\"thread_update\")"); 5950 Tcl_CreateCommand(interp, "thread_update", ip_rb_threadUpdateCommand, 5951 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 5952#endif 5953} 5954 5955 5956#if TCL_MAJOR_VERSION >= 8 5957static int 5958ip_rb_replaceSlaveTkCmdsObjCmd(clientData, interp, objc, objv) 5959 ClientData clientData; 5960 Tcl_Interp *interp; 5961 int objc; 5962 Tcl_Obj *CONST objv[]; 5963#else /* TCL_MAJOR_VERSION < 8 */ 5964static int 5965ip_rb_replaceSlaveTkCmdsCommand(clientData, interp, objc, objv) 5966 ClientData clientData; 5967 Tcl_Interp *interp; 5968 int objc; 5969 char *objv[]; 5970#endif 5971{ 5972 char *slave_name; 5973 Tcl_Interp *slave; 5974 Tk_Window mainWin; 5975 5976 if (objc != 2) { 5977#ifdef Tcl_WrongNumArgs 5978 Tcl_WrongNumArgs(interp, 1, objv, "slave_name"); 5979#else 5980 char *nameString; 5981#if TCL_MAJOR_VERSION >= 8 5982 nameString = Tcl_GetStringFromObj(objv[0], (int*)NULL); 5983#else /* TCL_MAJOR_VERSION < 8 */ 5984 nameString = objv[0]; 5985#endif 5986 Tcl_AppendResult(interp, "wrong number of arguments: should be \"", 5987 nameString, " slave_name\"", (char *) NULL); 5988#endif 5989 } 5990 5991#if TCL_MAJOR_VERSION >= 8 5992 slave_name = Tcl_GetStringFromObj(objv[1], (int*)NULL); 5993#else 5994 slave_name = objv[1]; 5995#endif 5996 5997 slave = Tcl_GetSlave(interp, slave_name); 5998 if (slave == NULL) { 5999 Tcl_AppendResult(interp, "cannot find slave \"", 6000 slave_name, "\"", (char *)NULL); 6001 return TCL_ERROR; 6002 } 6003 mainWin = Tk_MainWindow(slave); 6004 6005 /* replace 'exit' command --> 'interp_exit' command */ 6006#if TCL_MAJOR_VERSION >= 8 6007 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\""); 6008 Tcl_CreateObjCommand(slave, "exit", ip_InterpExitObjCmd, 6009 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 6010#else /* TCL_MAJOR_VERSION < 8 */ 6011 DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\""); 6012 Tcl_CreateCommand(slave, "exit", ip_InterpExitCommand, 6013 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 6014#endif 6015 6016 /* replace vwait and tkwait */ 6017 ip_replace_wait_commands(slave, mainWin); 6018 6019 return TCL_OK; 6020} 6021 6022 6023#if TCL_MAJOR_VERSION >= 8 6024static int ip_rbNamespaceObjCmd _((ClientData, Tcl_Interp *, int, 6025 Tcl_Obj *CONST [])); 6026static int 6027ip_rbNamespaceObjCmd(clientData, interp, objc, objv) 6028 ClientData clientData; 6029 Tcl_Interp *interp; 6030 int objc; 6031 Tcl_Obj *CONST objv[]; 6032{ 6033 Tcl_CmdInfo info; 6034 int ret; 6035 6036 if (!Tcl_GetCommandInfo(interp, "__orig_namespace_command__", &(info))) { 6037 Tcl_ResetResult(interp); 6038 Tcl_AppendResult(interp, 6039 "invalid command name \"namespace\"", (char*)NULL); 6040 return TCL_ERROR; 6041 } 6042 6043 rbtk_eventloop_depth++; 6044 /* DUMP2("namespace wrapper enter depth == %d", rbtk_eventloop_depth); */ 6045 6046 if (info.isNativeObjectProc) { 6047 ret = (*(info.objProc))(info.objClientData, interp, objc, objv); 6048 } else { 6049 /* string interface */ 6050 int i; 6051 char **argv; 6052 6053 /* argv = (char **)Tcl_Alloc(sizeof(char *) * (objc + 1)); */ 6054 argv = RbTk_ALLOC_N(char *, (objc + 1)); 6055#if 0 /* use Tcl_Preserve/Release */ 6056 Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ 6057#endif 6058 6059 for(i = 0; i < objc; i++) { 6060 /* argv[i] = Tcl_GetString(objv[i]); */ 6061 argv[i] = Tcl_GetStringFromObj(objv[i], (int*)NULL); 6062 } 6063 argv[objc] = (char *)NULL; 6064 6065 ret = (*(info.proc))(info.clientData, interp, 6066 objc, (CONST84 char **)argv); 6067 6068#if 0 /* use Tcl_EventuallyFree */ 6069 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ 6070#else 6071#if 0 /* use Tcl_Preserve/Release */ 6072 Tcl_Release((ClientData)argv); /* XXXXXXXX */ 6073#else 6074 /* Tcl_Free((char*)argv); */ 6075 ckfree((char*)argv); 6076#endif 6077#endif 6078 } 6079 6080 /* DUMP2("namespace wrapper exit depth == %d", rbtk_eventloop_depth); */ 6081 rbtk_eventloop_depth--; 6082 6083 return ret; 6084} 6085#endif 6086 6087static void 6088ip_wrap_namespace_command(interp) 6089 Tcl_Interp *interp; 6090{ 6091#if TCL_MAJOR_VERSION >= 8 6092 Tcl_CmdInfo orig_info; 6093 6094 if (!Tcl_GetCommandInfo(interp, "namespace", &(orig_info))) { 6095 return; 6096 } 6097 6098 if (orig_info.isNativeObjectProc) { 6099 Tcl_CreateObjCommand(interp, "__orig_namespace_command__", 6100 orig_info.objProc, orig_info.objClientData, 6101 orig_info.deleteProc); 6102 } else { 6103 Tcl_CreateCommand(interp, "__orig_namespace_command__", 6104 orig_info.proc, orig_info.clientData, 6105 orig_info.deleteProc); 6106 } 6107 6108 Tcl_CreateObjCommand(interp, "namespace", ip_rbNamespaceObjCmd, 6109 (ClientData) 0, (Tcl_CmdDeleteProc *)NULL); 6110#endif 6111} 6112 6113 6114/* call when interpreter is deleted */ 6115static void 6116#ifdef HAVE_PROTOTYPES 6117ip_CallWhenDeleted(ClientData clientData, Tcl_Interp *ip) 6118#else 6119ip_CallWhenDeleted(clientData, ip) 6120 ClientData clientData; 6121 Tcl_Interp *ip; 6122#endif 6123{ 6124 int thr_crit_bup; 6125 /* Tk_Window main_win = (Tk_Window) clientData; */ 6126 6127 DUMP1("start ip_CallWhenDeleted"); 6128 thr_crit_bup = rb_thread_critical; 6129 rb_thread_critical = Qtrue; 6130 6131 ip_finalize(ip); 6132 6133 DUMP1("finish ip_CallWhenDeleted"); 6134 rb_thread_critical = thr_crit_bup; 6135} 6136 6137/*--------------------------------------------------------*/ 6138 6139/* initialize interpreter */ 6140static VALUE 6141ip_init(argc, argv, self) 6142 int argc; 6143 VALUE *argv; 6144 VALUE self; 6145{ 6146 struct tcltkip *ptr; /* tcltkip data struct */ 6147 VALUE argv0, opts; 6148 int cnt; 6149 int st; 6150 int with_tk = 1; 6151 Tk_Window mainWin = (Tk_Window)NULL; 6152 6153 /* security check */ 6154 if (rb_safe_level() >= 4) { 6155 rb_raise(rb_eSecurityError, 6156 "Cannot create a TclTkIp object at level %d", 6157 rb_safe_level()); 6158 } 6159 6160 /* create object */ 6161 Data_Get_Struct(self, struct tcltkip, ptr); 6162 ptr = ALLOC(struct tcltkip); 6163 /* ptr = RbTk_ALLOC_N(struct tcltkip, 1); */ 6164 DATA_PTR(self) = ptr; 6165#ifdef RUBY_USE_NATIVE_THREAD 6166 ptr->tk_thread_id = 0; 6167#endif 6168 ptr->ref_count = 0; 6169 ptr->allow_ruby_exit = 1; 6170 ptr->return_value = 0; 6171 6172 /* from Tk_Main() */ 6173 DUMP1("Tcl_CreateInterp"); 6174 ptr->ip = ruby_tcl_create_ip_and_stubs_init(&st); 6175 if (ptr->ip == NULL) { 6176 switch(st) { 6177 case TCLTK_STUBS_OK: 6178 break; 6179 case NO_TCL_DLL: 6180 rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll"); 6181 case NO_FindExecutable: 6182 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable"); 6183 case NO_CreateInterp: 6184 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_CreateInterp()"); 6185 case NO_DeleteInterp: 6186 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_DeleteInterp()"); 6187 case FAIL_CreateInterp: 6188 rb_raise(rb_eRuntimeError, "tcltklib: fail to create a new IP"); 6189 case FAIL_Tcl_InitStubs: 6190 rb_raise(rb_eRuntimeError, "tcltklib: fail to Tcl_InitStubs()"); 6191 default: 6192 rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tcl_create_ip_and_stubs_init", st); 6193 } 6194 } 6195 6196#if TCL_MAJOR_VERSION >= 8 6197#if TCL_NAMESPACE_DEBUG 6198 DUMP1("get current namespace"); 6199 if ((ptr->default_ns = Tcl_GetCurrentNamespace(ptr->ip)) 6200 == (Tcl_Namespace*)NULL) { 6201 rb_raise(rb_eRuntimeError, "a new Tk interpreter has a NULL namespace"); 6202 } 6203#endif 6204#endif 6205 6206 rbtk_preserve_ip(ptr); 6207 DUMP2("IP ref_count = %d", ptr->ref_count); 6208 current_interp = ptr->ip; 6209 6210 ptr->has_orig_exit 6211 = Tcl_GetCommandInfo(ptr->ip, "exit", &(ptr->orig_exit_info)); 6212 6213#if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT 6214 call_tclkit_init_script(current_interp); 6215 6216# if 10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION > 84 6217 { 6218 Tcl_DString encodingName; 6219 Tcl_GetEncodingNameFromEnvironment(&encodingName); 6220 if (strcmp(Tcl_DStringValue(&encodingName), Tcl_GetEncodingName(NULL))) { 6221 /* fails, so we set a variable and do it in the boot.tcl script */ 6222 Tcl_SetSystemEncoding(NULL, Tcl_DStringValue(&encodingName)); 6223 } 6224 Tcl_SetVar(current_interp, "tclkit_system_encoding", Tcl_DStringValue(&encodingName), 0); 6225 Tcl_DStringFree(&encodingName); 6226 } 6227# endif 6228#endif 6229 6230 /* set variables */ 6231 Tcl_Eval(ptr->ip, "set argc 0; set argv {}; set argv0 tcltklib.so"); 6232 6233 cnt = rb_scan_args(argc, argv, "02", &argv0, &opts); 6234 switch(cnt) { 6235 case 2: 6236 /* options */ 6237 if (NIL_P(opts) || opts == Qfalse) { 6238 /* without Tk */ 6239 with_tk = 0; 6240 } else { 6241 /* Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), 0); */ 6242 Tcl_SetVar(ptr->ip, "argv", StringValuePtr(opts), TCL_GLOBAL_ONLY); 6243 Tcl_Eval(ptr->ip, "set argc [llength $argv]"); 6244 } 6245 case 1: 6246 /* argv0 */ 6247 if (!NIL_P(argv0)) { 6248 if (strncmp(StringValuePtr(argv0), "-e", 3) == 0 6249 || strncmp(StringValuePtr(argv0), "-", 2) == 0) { 6250 Tcl_SetVar(ptr->ip, "argv0", "ruby", TCL_GLOBAL_ONLY); 6251 } else { 6252 /* Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), 0); */ 6253 Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), 6254 TCL_GLOBAL_ONLY); 6255 } 6256 } 6257 case 0: 6258 /* no args */ 6259 ; 6260 } 6261 6262 /* from Tcl_AppInit() */ 6263 DUMP1("Tcl_Init"); 6264#if (defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT) && (!defined KIT_LITE) && (10 * TCL_MAJOR_VERSION + TCL_MINOR_VERSION == 85) 6265 /*************************************************************************/ 6266 /* FIX ME (2010/06/28) */ 6267 /* Don't use ::chan command for Mk4tcl + tclvfs-1.4 on Tcl8.5. */ 6268 /* It fails to access VFS files because of vfs::zstream. */ 6269 /* So, force to use ::rechan by temporaly hiding ::chan. */ 6270 /*************************************************************************/ 6271 Tcl_Eval(ptr->ip, "catch {rename ::chan ::_tmp_chan}"); 6272 if (Tcl_Init(ptr->ip) == TCL_ERROR) { 6273 rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); 6274 } 6275 Tcl_Eval(ptr->ip, "catch {rename ::_tmp_chan ::chan}"); 6276#else 6277 if (Tcl_Init(ptr->ip) == TCL_ERROR) { 6278 rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip)); 6279 } 6280#endif 6281 6282 st = ruby_tcl_stubs_init(); 6283 /* from Tcl_AppInit() */ 6284 if (with_tk) { 6285 DUMP1("Tk_Init"); 6286 st = ruby_tk_stubs_init(ptr->ip); 6287 switch(st) { 6288 case TCLTK_STUBS_OK: 6289 break; 6290 case NO_Tk_Init: 6291 rb_raise(rb_eLoadError, "tcltklib: can't find Tk_Init()"); 6292 case FAIL_Tk_Init: 6293 rb_raise(rb_eRuntimeError, "tcltklib: fail to Tk_Init(). %s", 6294 Tcl_GetStringResult(ptr->ip)); 6295 case FAIL_Tk_InitStubs: 6296 rb_raise(rb_eRuntimeError, "tcltklib: fail to Tk_InitStubs(). %s", 6297 Tcl_GetStringResult(ptr->ip)); 6298 default: 6299 rb_raise(rb_eRuntimeError, "tcltklib: unknown error(%d) on ruby_tk_stubs_init", st); 6300 } 6301 6302 DUMP1("Tcl_StaticPackage(\"Tk\")"); 6303#if TCL_MAJOR_VERSION >= 8 6304 Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, Tk_SafeInit); 6305#else /* TCL_MAJOR_VERSION < 8 */ 6306 Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, 6307 (Tcl_PackageInitProc *) NULL); 6308#endif 6309 6310#ifdef RUBY_USE_NATIVE_THREAD 6311 /* set Tk thread ID */ 6312 ptr->tk_thread_id = Tcl_GetCurrentThread(); 6313#endif 6314 /* get main window */ 6315 mainWin = Tk_MainWindow(ptr->ip); 6316 Tk_Preserve((ClientData)mainWin); 6317 } 6318 6319 /* add ruby command to the interpreter */ 6320#if TCL_MAJOR_VERSION >= 8 6321 DUMP1("Tcl_CreateObjCommand(\"ruby\")"); 6322 Tcl_CreateObjCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL, 6323 (Tcl_CmdDeleteProc *)NULL); 6324 DUMP1("Tcl_CreateObjCommand(\"ruby_eval\")"); 6325 Tcl_CreateObjCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL, 6326 (Tcl_CmdDeleteProc *)NULL); 6327 DUMP1("Tcl_CreateObjCommand(\"ruby_cmd\")"); 6328 Tcl_CreateObjCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL, 6329 (Tcl_CmdDeleteProc *)NULL); 6330#else /* TCL_MAJOR_VERSION < 8 */ 6331 DUMP1("Tcl_CreateCommand(\"ruby\")"); 6332 Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL, 6333 (Tcl_CmdDeleteProc *)NULL); 6334 DUMP1("Tcl_CreateCommand(\"ruby_eval\")"); 6335 Tcl_CreateCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL, 6336 (Tcl_CmdDeleteProc *)NULL); 6337 DUMP1("Tcl_CreateCommand(\"ruby_cmd\")"); 6338 Tcl_CreateCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL, 6339 (Tcl_CmdDeleteProc *)NULL); 6340#endif 6341 6342 /* add 'interp_exit', 'ruby_exit' and replace 'exit' command */ 6343#if TCL_MAJOR_VERSION >= 8 6344 DUMP1("Tcl_CreateObjCommand(\"interp_exit\")"); 6345 Tcl_CreateObjCommand(ptr->ip, "interp_exit", ip_InterpExitObjCmd, 6346 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 6347 DUMP1("Tcl_CreateObjCommand(\"ruby_exit\")"); 6348 Tcl_CreateObjCommand(ptr->ip, "ruby_exit", ip_RubyExitObjCmd, 6349 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 6350 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"ruby_exit\""); 6351 Tcl_CreateObjCommand(ptr->ip, "exit", ip_RubyExitObjCmd, 6352 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 6353#else /* TCL_MAJOR_VERSION < 8 */ 6354 DUMP1("Tcl_CreateCommand(\"interp_exit\")"); 6355 Tcl_CreateCommand(ptr->ip, "interp_exit", ip_InterpExitCommand, 6356 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 6357 DUMP1("Tcl_CreateCommand(\"ruby_exit\")"); 6358 Tcl_CreateCommand(ptr->ip, "ruby_exit", ip_RubyExitCommand, 6359 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 6360 DUMP1("Tcl_CreateCommand(\"exit\") --> \"ruby_exit\""); 6361 Tcl_CreateCommand(ptr->ip, "exit", ip_RubyExitCommand, 6362 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 6363#endif 6364 6365 /* replace vwait and tkwait */ 6366 ip_replace_wait_commands(ptr->ip, mainWin); 6367 6368 /* wrap namespace command */ 6369 ip_wrap_namespace_command(ptr->ip); 6370 6371 /* define command to replace commands which depend on slave's MainWindow */ 6372#if TCL_MAJOR_VERSION >= 8 6373 Tcl_CreateObjCommand(ptr->ip, "__replace_slave_tk_commands__", 6374 ip_rb_replaceSlaveTkCmdsObjCmd, 6375 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); 6376#else /* TCL_MAJOR_VERSION < 8 */ 6377 Tcl_CreateCommand(ptr->ip, "__replace_slave_tk_commands__", 6378 ip_rb_replaceSlaveTkCmdsCommand, 6379 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); 6380#endif 6381 6382 /* set finalizer */ 6383 Tcl_CallWhenDeleted(ptr->ip, ip_CallWhenDeleted, (ClientData)mainWin); 6384 6385 if (mainWin != (Tk_Window)NULL) { 6386 Tk_Release((ClientData)mainWin); 6387 } 6388 6389 return self; 6390} 6391 6392static VALUE 6393ip_create_slave_core(interp, argc, argv) 6394 VALUE interp; 6395 int argc; 6396 VALUE *argv; 6397{ 6398 struct tcltkip *master = get_ip(interp); 6399 struct tcltkip *slave = ALLOC(struct tcltkip); 6400 /* struct tcltkip *slave = RbTk_ALLOC_N(struct tcltkip, 1); */ 6401 VALUE safemode; 6402 VALUE name; 6403 int safe; 6404 int thr_crit_bup; 6405 Tk_Window mainWin; 6406 6407 /* ip is deleted? */ 6408 if (deleted_ip(master)) { 6409 return rb_exc_new2(rb_eRuntimeError, 6410 "deleted master cannot create a new slave"); 6411 } 6412 6413 name = argv[0]; 6414 safemode = argv[1]; 6415 6416 if (Tcl_IsSafe(master->ip) == 1) { 6417 safe = 1; 6418 } else if (safemode == Qfalse || NIL_P(safemode)) { 6419 safe = 0; 6420 /* rb_secure(4); */ /* already checked */ 6421 } else { 6422 safe = 1; 6423 } 6424 6425 thr_crit_bup = rb_thread_critical; 6426 rb_thread_critical = Qtrue; 6427 6428#if 0 6429 /* init Tk */ 6430 if (RTEST(with_tk)) { 6431 volatile VALUE exc; 6432 if (!tk_stubs_init_p()) { 6433 exc = tcltkip_init_tk(interp); 6434 if (!NIL_P(exc)) { 6435 rb_thread_critical = thr_crit_bup; 6436 return exc; 6437 } 6438 } 6439 } 6440#endif 6441 6442 /* create slave-ip */ 6443#ifdef RUBY_USE_NATIVE_THREAD 6444 /* slave->tk_thread_id = 0; */ 6445 slave->tk_thread_id = master->tk_thread_id; /* == current thread */ 6446#endif 6447 slave->ref_count = 0; 6448 slave->allow_ruby_exit = 0; 6449 slave->return_value = 0; 6450 6451 slave->ip = Tcl_CreateSlave(master->ip, StringValuePtr(name), safe); 6452 if (slave->ip == NULL) { 6453 rb_thread_critical = thr_crit_bup; 6454 return rb_exc_new2(rb_eRuntimeError, 6455 "fail to create the new slave interpreter"); 6456 } 6457#if TCL_MAJOR_VERSION >= 8 6458#if TCL_NAMESPACE_DEBUG 6459 slave->default_ns = Tcl_GetCurrentNamespace(slave->ip); 6460#endif 6461#endif 6462 rbtk_preserve_ip(slave); 6463 6464 slave->has_orig_exit 6465 = Tcl_GetCommandInfo(slave->ip, "exit", &(slave->orig_exit_info)); 6466 6467 /* replace 'exit' command --> 'interp_exit' command */ 6468 mainWin = (tk_stubs_init_p())? Tk_MainWindow(slave->ip): (Tk_Window)NULL; 6469#if TCL_MAJOR_VERSION >= 8 6470 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\""); 6471 Tcl_CreateObjCommand(slave->ip, "exit", ip_InterpExitObjCmd, 6472 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 6473#else /* TCL_MAJOR_VERSION < 8 */ 6474 DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\""); 6475 Tcl_CreateCommand(slave->ip, "exit", ip_InterpExitCommand, 6476 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 6477#endif 6478 6479 /* replace vwait and tkwait */ 6480 ip_replace_wait_commands(slave->ip, mainWin); 6481 6482 /* wrap namespace command */ 6483 ip_wrap_namespace_command(slave->ip); 6484 6485 /* define command to replace cmds which depend on slave-slave's MainWin */ 6486#if TCL_MAJOR_VERSION >= 8 6487 Tcl_CreateObjCommand(slave->ip, "__replace_slave_tk_commands__", 6488 ip_rb_replaceSlaveTkCmdsObjCmd, 6489 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); 6490#else /* TCL_MAJOR_VERSION < 8 */ 6491 Tcl_CreateCommand(slave->ip, "__replace_slave_tk_commands__", 6492 ip_rb_replaceSlaveTkCmdsCommand, 6493 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL); 6494#endif 6495 6496 /* set finalizer */ 6497 Tcl_CallWhenDeleted(slave->ip, ip_CallWhenDeleted, (ClientData)mainWin); 6498 6499 rb_thread_critical = thr_crit_bup; 6500 6501 return Data_Wrap_Struct(CLASS_OF(interp), 0, ip_free, slave); 6502} 6503 6504static VALUE 6505ip_create_slave(argc, argv, self) 6506 int argc; 6507 VALUE *argv; 6508 VALUE self; 6509{ 6510 struct tcltkip *master = get_ip(self); 6511 VALUE safemode; 6512 VALUE name; 6513 VALUE callargv[2]; 6514 6515 /* ip is deleted? */ 6516 if (deleted_ip(master)) { 6517 rb_raise(rb_eRuntimeError, 6518 "deleted master cannot create a new slave interpreter"); 6519 } 6520 6521 /* argument check */ 6522 if (rb_scan_args(argc, argv, "11", &name, &safemode) == 1) { 6523 safemode = Qfalse; 6524 } 6525 if (Tcl_IsSafe(master->ip) != 1 6526 && (safemode == Qfalse || NIL_P(safemode))) { 6527 rb_secure(4); 6528 } 6529 6530 StringValue(name); 6531 callargv[0] = name; 6532 callargv[1] = safemode; 6533 6534 return tk_funcall(ip_create_slave_core, 2, callargv, self); 6535} 6536 6537 6538/* self is slave of master? */ 6539static VALUE 6540ip_is_slave_of_p(self, master) 6541 VALUE self, master; 6542{ 6543 if (!rb_obj_is_kind_of(master, tcltkip_class)) { 6544 rb_raise(rb_eArgError, "expected TclTkIp object"); 6545 } 6546 6547 if (Tcl_GetMaster(get_ip(self)->ip) == get_ip(master)->ip) { 6548 return Qtrue; 6549 } else { 6550 return Qfalse; 6551 } 6552} 6553 6554 6555/* create console (if supported) */ 6556#if defined(MAC_TCL) || defined(__WIN32__) 6557#if TCL_MAJOR_VERSION < 8 \ 6558 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0) \ 6559 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \ 6560 && (TCL_RELEASE_LEVEL == TCL_ALPHA_RELEASE \ 6561 || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE \ 6562 && TCL_RELEASE_SERIAL < 2) ) ) 6563EXTERN void TkConsoleCreate _((void)); 6564#endif 6565#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \ 6566 && ( (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE \ 6567 && TCL_RELEASE_SERIAL == 0) \ 6568 || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE \ 6569 && TCL_RELEASE_SERIAL >= 2) ) 6570EXTERN void TkConsoleCreate_ _((void)); 6571#endif 6572#endif 6573static VALUE 6574ip_create_console_core(interp, argc, argv) 6575 VALUE interp; 6576 int argc; /* dummy */ 6577 VALUE *argv; /* dummy */ 6578{ 6579 struct tcltkip *ptr = get_ip(interp); 6580 6581 if (!tk_stubs_init_p()) { 6582 tcltkip_init_tk(interp); 6583 } 6584 6585 if (Tcl_GetVar(ptr->ip,"tcl_interactive",TCL_GLOBAL_ONLY) == (char*)NULL) { 6586 Tcl_SetVar(ptr->ip, "tcl_interactive", "0", TCL_GLOBAL_ONLY); 6587 } 6588 6589#if TCL_MAJOR_VERSION > 8 \ 6590 || (TCL_MAJOR_VERSION == 8 \ 6591 && (TCL_MINOR_VERSION > 1 \ 6592 || (TCL_MINOR_VERSION == 1 \ 6593 && TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE \ 6594 && TCL_RELEASE_SERIAL >= 1) ) ) 6595 Tk_InitConsoleChannels(ptr->ip); 6596 6597 if (Tk_CreateConsoleWindow(ptr->ip) != TCL_OK) { 6598 rb_raise(rb_eRuntimeError, "fail to create console-window"); 6599 } 6600#else 6601#if defined(MAC_TCL) || defined(__WIN32__) 6602#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 1 \ 6603 && ( (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE && TCL_RELEASE_SERIAL == 0) \ 6604 || (TCL_RELEASE_LEVEL == TCL_BETA_RELEASE && TCL_RELEASE_SERIAL >= 2) ) 6605 TkConsoleCreate_(); 6606#else 6607 TkConsoleCreate(); 6608#endif 6609 6610 if (TkConsoleInit(ptr->ip) != TCL_OK) { 6611 rb_raise(rb_eRuntimeError, "fail to create console-window"); 6612 } 6613#else 6614 rb_notimplement(); 6615#endif 6616#endif 6617 6618 return interp; 6619} 6620 6621static VALUE 6622ip_create_console(self) 6623 VALUE self; 6624{ 6625 struct tcltkip *ptr = get_ip(self); 6626 6627 /* ip is deleted? */ 6628 if (deleted_ip(ptr)) { 6629 rb_raise(rb_eRuntimeError, "interpreter is deleted"); 6630 } 6631 6632 return tk_funcall(ip_create_console_core, 0, (VALUE*)NULL, self); 6633} 6634 6635/* make ip "safe" */ 6636static VALUE 6637ip_make_safe_core(interp, argc, argv) 6638 VALUE interp; 6639 int argc; /* dummy */ 6640 VALUE *argv; /* dummy */ 6641{ 6642 struct tcltkip *ptr = get_ip(interp); 6643 Tk_Window mainWin; 6644 6645 /* ip is deleted? */ 6646 if (deleted_ip(ptr)) { 6647 return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted"); 6648 } 6649 6650 if (Tcl_MakeSafe(ptr->ip) == TCL_ERROR) { 6651 /* return rb_exc_new2(rb_eRuntimeError, 6652 Tcl_GetStringResult(ptr->ip)); */ 6653 return create_ip_exc(interp, rb_eRuntimeError, "%s", 6654 Tcl_GetStringResult(ptr->ip)); 6655 } 6656 6657 ptr->allow_ruby_exit = 0; 6658 6659 /* replace 'exit' command --> 'interp_exit' command */ 6660 mainWin = (tk_stubs_init_p())? Tk_MainWindow(ptr->ip): (Tk_Window)NULL; 6661#if TCL_MAJOR_VERSION >= 8 6662 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\""); 6663 Tcl_CreateObjCommand(ptr->ip, "exit", ip_InterpExitObjCmd, 6664 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 6665#else /* TCL_MAJOR_VERSION < 8 */ 6666 DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\""); 6667 Tcl_CreateCommand(ptr->ip, "exit", ip_InterpExitCommand, 6668 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 6669#endif 6670 6671 return interp; 6672} 6673 6674static VALUE 6675ip_make_safe(self) 6676 VALUE self; 6677{ 6678 struct tcltkip *ptr = get_ip(self); 6679 6680 /* ip is deleted? */ 6681 if (deleted_ip(ptr)) { 6682 rb_raise(rb_eRuntimeError, "interpreter is deleted"); 6683 } 6684 6685 return tk_funcall(ip_make_safe_core, 0, (VALUE*)NULL, self); 6686} 6687 6688/* is safe? */ 6689static VALUE 6690ip_is_safe_p(self) 6691 VALUE self; 6692{ 6693 struct tcltkip *ptr = get_ip(self); 6694 6695 /* ip is deleted? */ 6696 if (deleted_ip(ptr)) { 6697 rb_raise(rb_eRuntimeError, "interpreter is deleted"); 6698 } 6699 6700 if (Tcl_IsSafe(ptr->ip)) { 6701 return Qtrue; 6702 } else { 6703 return Qfalse; 6704 } 6705} 6706 6707/* allow_ruby_exit? */ 6708static VALUE 6709ip_allow_ruby_exit_p(self) 6710 VALUE self; 6711{ 6712 struct tcltkip *ptr = get_ip(self); 6713 6714 /* ip is deleted? */ 6715 if (deleted_ip(ptr)) { 6716 rb_raise(rb_eRuntimeError, "interpreter is deleted"); 6717 } 6718 6719 if (ptr->allow_ruby_exit) { 6720 return Qtrue; 6721 } else { 6722 return Qfalse; 6723 } 6724} 6725 6726/* allow_ruby_exit = mode */ 6727static VALUE 6728ip_allow_ruby_exit_set(self, val) 6729 VALUE self, val; 6730{ 6731 struct tcltkip *ptr = get_ip(self); 6732 Tk_Window mainWin; 6733 6734 rb_secure(4); 6735 6736 /* ip is deleted? */ 6737 if (deleted_ip(ptr)) { 6738 rb_raise(rb_eRuntimeError, "interpreter is deleted"); 6739 } 6740 6741 if (Tcl_IsSafe(ptr->ip)) { 6742 rb_raise(rb_eSecurityError, 6743 "insecure operation on a safe interpreter"); 6744 } 6745 6746 /* 6747 * Because of cross-threading, the following line may fail to find 6748 * the MainWindow, even if the Tcl/Tk interpreter has one or more. 6749 * But it has no problem. Current implementation of both type of 6750 * the "exit" command don't need maiinWin token. 6751 */ 6752 mainWin = (tk_stubs_init_p())? Tk_MainWindow(ptr->ip): (Tk_Window)NULL; 6753 6754 if (RTEST(val)) { 6755 ptr->allow_ruby_exit = 1; 6756#if TCL_MAJOR_VERSION >= 8 6757 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"ruby_exit\""); 6758 Tcl_CreateObjCommand(ptr->ip, "exit", ip_RubyExitObjCmd, 6759 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 6760#else /* TCL_MAJOR_VERSION < 8 */ 6761 DUMP1("Tcl_CreateCommand(\"exit\") --> \"ruby_exit\""); 6762 Tcl_CreateCommand(ptr->ip, "exit", ip_RubyExitCommand, 6763 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 6764#endif 6765 return Qtrue; 6766 6767 } else { 6768 ptr->allow_ruby_exit = 0; 6769#if TCL_MAJOR_VERSION >= 8 6770 DUMP1("Tcl_CreateObjCommand(\"exit\") --> \"interp_exit\""); 6771 Tcl_CreateObjCommand(ptr->ip, "exit", ip_InterpExitObjCmd, 6772 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 6773#else /* TCL_MAJOR_VERSION < 8 */ 6774 DUMP1("Tcl_CreateCommand(\"exit\") --> \"interp_exit\""); 6775 Tcl_CreateCommand(ptr->ip, "exit", ip_InterpExitCommand, 6776 (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL); 6777#endif 6778 return Qfalse; 6779 } 6780} 6781 6782/* delete interpreter */ 6783static VALUE 6784ip_delete(self) 6785 VALUE self; 6786{ 6787 int thr_crit_bup; 6788 struct tcltkip *ptr = get_ip(self); 6789 6790 /* if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp*)NULL) { */ 6791 if (deleted_ip(ptr)) { 6792 DUMP1("delete deleted IP"); 6793 return Qnil; 6794 } 6795 6796 thr_crit_bup = rb_thread_critical; 6797 rb_thread_critical = Qtrue; 6798 6799 DUMP1("delete interp"); 6800 if (!Tcl_InterpDeleted(ptr->ip)) { 6801 DUMP1("call ip_finalize"); 6802 ip_finalize(ptr->ip); 6803 6804 Tcl_DeleteInterp(ptr->ip); 6805 Tcl_Release(ptr->ip); 6806 } 6807 6808 rb_thread_critical = thr_crit_bup; 6809 6810 return Qnil; 6811} 6812 6813 6814/* is deleted? */ 6815static VALUE 6816ip_has_invalid_namespace_p(self) 6817 VALUE self; 6818{ 6819 struct tcltkip *ptr = get_ip(self); 6820 6821 if (ptr == (struct tcltkip *)NULL || ptr->ip == (Tcl_Interp *)NULL) { 6822 /* deleted IP */ 6823 return Qtrue; 6824 } 6825 6826#if TCL_NAMESPACE_DEBUG 6827 if (rbtk_invalid_namespace(ptr)) { 6828 return Qtrue; 6829 } else { 6830 return Qfalse; 6831 } 6832#else 6833 return Qfalse; 6834#endif 6835} 6836 6837static VALUE 6838ip_is_deleted_p(self) 6839 VALUE self; 6840{ 6841 struct tcltkip *ptr = get_ip(self); 6842 6843 if (deleted_ip(ptr)) { 6844 return Qtrue; 6845 } else { 6846 return Qfalse; 6847 } 6848} 6849 6850static VALUE 6851ip_has_mainwindow_p_core(self, argc, argv) 6852 VALUE self; 6853 int argc; /* dummy */ 6854 VALUE *argv; /* dummy */ 6855{ 6856 struct tcltkip *ptr = get_ip(self); 6857 6858 if (deleted_ip(ptr) || !tk_stubs_init_p()) { 6859 return Qnil; 6860 } else if (Tk_MainWindow(ptr->ip) == (Tk_Window)NULL) { 6861 return Qfalse; 6862 } else { 6863 return Qtrue; 6864 } 6865} 6866 6867static VALUE 6868ip_has_mainwindow_p(self) 6869 VALUE self; 6870{ 6871 return tk_funcall(ip_has_mainwindow_p_core, 0, (VALUE*)NULL, self); 6872} 6873 6874 6875/*** ruby string <=> tcl object ***/ 6876#if TCL_MAJOR_VERSION >= 8 6877static VALUE 6878get_str_from_obj(obj) 6879 Tcl_Obj *obj; 6880{ 6881 int len, binary = 0; 6882 const char *s; 6883 volatile VALUE str; 6884 6885#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 6886 s = Tcl_GetStringFromObj(obj, &len); 6887#else 6888#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION <= 3 6889 /* TCL_VERSION 8.1 -- 8.3 */ 6890 if (Tcl_GetCharLength(obj) != Tcl_UniCharLen(Tcl_GetUnicode(obj))) { 6891 /* possibly binary string */ 6892 s = (char *)Tcl_GetByteArrayFromObj(obj, &len); 6893 binary = 1; 6894 } else { 6895 /* possibly text string */ 6896 s = Tcl_GetStringFromObj(obj, &len); 6897 } 6898#else /* TCL_VERSION >= 8.4 */ 6899 if (IS_TCL_BYTEARRAY(obj)) { 6900 s = (char *)Tcl_GetByteArrayFromObj(obj, &len); 6901 binary = 1; 6902 } else { 6903 s = Tcl_GetStringFromObj(obj, &len); 6904 } 6905 6906#endif 6907#endif 6908 str = s ? rb_str_new(s, len) : rb_str_new2(""); 6909 if (binary) { 6910#ifdef HAVE_RUBY_ENCODING_H 6911 rb_enc_associate_index(str, ENCODING_INDEX_BINARY); 6912#endif 6913 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY); 6914#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1) 6915 } else { 6916#ifdef HAVE_RUBY_ENCODING_H 6917 rb_enc_associate_index(str, ENCODING_INDEX_UTF8); 6918#endif 6919 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8); 6920#endif 6921 } 6922 return str; 6923} 6924 6925static Tcl_Obj * 6926get_obj_from_str(str) 6927 VALUE str; 6928{ 6929 const char *s = StringValuePtr(str); 6930 6931#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0 6932 return Tcl_NewStringObj((char*)s, RSTRING_LEN(str)); 6933#else /* TCL_VERSION >= 8.1 */ 6934 VALUE enc = rb_attr_get(str, ID_at_enc); 6935 6936 if (!NIL_P(enc)) { 6937 StringValue(enc); 6938 if (strcmp(RSTRING_PTR(enc), "binary") == 0) { 6939 /* binary string */ 6940 return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str)); 6941 } else { 6942 /* text string */ 6943 return Tcl_NewStringObj(s, RSTRING_LENINT(str)); 6944 } 6945#ifdef HAVE_RUBY_ENCODING_H 6946 } else if (rb_enc_get_index(str) == ENCODING_INDEX_BINARY) { 6947 /* binary string */ 6948 return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str)); 6949#endif 6950 } else if (memchr(s, 0, RSTRING_LEN(str))) { 6951 /* probably binary string */ 6952 return Tcl_NewByteArrayObj((const unsigned char *)s, RSTRING_LENINT(str)); 6953 } else { 6954 /* probably text string */ 6955 return Tcl_NewStringObj(s, RSTRING_LENINT(str)); 6956 } 6957#endif 6958} 6959#endif /* ruby string <=> tcl object */ 6960 6961static VALUE 6962ip_get_result_string_obj(interp) 6963 Tcl_Interp *interp; 6964{ 6965#if TCL_MAJOR_VERSION >= 8 6966 Tcl_Obj *retObj; 6967 volatile VALUE strval; 6968 6969 retObj = Tcl_GetObjResult(interp); 6970 Tcl_IncrRefCount(retObj); 6971 strval = get_str_from_obj(retObj); 6972 RbTk_OBJ_UNTRUST(strval); 6973 Tcl_ResetResult(interp); 6974 Tcl_DecrRefCount(retObj); 6975 return strval; 6976#else 6977 return rb_tainted_str_new2(interp->result); 6978#endif 6979} 6980 6981/* call Tcl/Tk functions on the eventloop thread */ 6982static VALUE 6983callq_safelevel_handler(arg, callq) 6984 VALUE arg; 6985 VALUE callq; 6986{ 6987 struct call_queue *q; 6988 6989 Data_Get_Struct(callq, struct call_queue, q); 6990 DUMP2("(safe-level handler) $SAFE = %d", q->safe_level); 6991 rb_set_safe_level(q->safe_level); 6992 return((q->func)(q->interp, q->argc, q->argv)); 6993} 6994 6995static int call_queue_handler _((Tcl_Event *, int)); 6996static int 6997call_queue_handler(evPtr, flags) 6998 Tcl_Event *evPtr; 6999 int flags; 7000{ 7001 struct call_queue *q = (struct call_queue *)evPtr; 7002 volatile VALUE ret; 7003 volatile VALUE q_dat; 7004 volatile VALUE thread = q->thread; 7005 struct tcltkip *ptr; 7006 7007 DUMP2("do_call_queue_handler : evPtr = %p", evPtr); 7008 DUMP2("call_queue_handler thread : %lx", rb_thread_current()); 7009 DUMP2("added by thread : %lx", thread); 7010 7011 if (*(q->done)) { 7012 DUMP1("processed by another event-loop"); 7013 return 0; 7014 } else { 7015 DUMP1("process it on current event-loop"); 7016 } 7017 7018#ifdef RUBY_VM 7019 if (RTEST(rb_funcall(thread, ID_alive_p, 0)) 7020 && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) { 7021#else 7022 if (RTEST(rb_thread_alive_p(thread)) 7023 && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) { 7024#endif 7025 DUMP1("caller is not yet ready to receive the result -> pending"); 7026 return 0; 7027 } 7028 7029 /* process it */ 7030 *(q->done) = 1; 7031 7032 /* deleted ipterp ? */ 7033 ptr = get_ip(q->interp); 7034 if (deleted_ip(ptr)) { 7035 /* deleted IP --> ignore */ 7036 return 1; 7037 } 7038 7039 /* incr internal handler mark */ 7040 rbtk_internal_eventloop_handler++; 7041 7042 /* check safe-level */ 7043 if (rb_safe_level() != q->safe_level) { 7044 /* q_dat = Data_Wrap_Struct(rb_cData,0,-1,q); */ 7045 q_dat = Data_Wrap_Struct(rb_cData,call_queue_mark,-1,q); 7046 ret = rb_funcall(rb_proc_new(callq_safelevel_handler, q_dat), 7047 ID_call, 0); 7048 rb_gc_force_recycle(q_dat); 7049 q_dat = (VALUE)NULL; 7050 } else { 7051 DUMP2("call function (for caller thread:%lx)", thread); 7052 DUMP2("call function (current thread:%lx)", rb_thread_current()); 7053 ret = (q->func)(q->interp, q->argc, q->argv); 7054 } 7055 7056 /* set result */ 7057 RARRAY_PTR(q->result)[0] = ret; 7058 ret = (VALUE)NULL; 7059 7060 /* decr internal handler mark */ 7061 rbtk_internal_eventloop_handler--; 7062 7063 /* complete */ 7064 *(q->done) = -1; 7065 7066 /* unlink ruby objects */ 7067 q->argv = (VALUE*)NULL; 7068 q->interp = (VALUE)NULL; 7069 q->result = (VALUE)NULL; 7070 q->thread = (VALUE)NULL; 7071 7072 /* back to caller */ 7073#ifdef RUBY_VM 7074 if (RTEST(rb_funcall(thread, ID_alive_p, 0, 0))) { 7075#else 7076 if (RTEST(rb_thread_alive_p(thread))) { 7077#endif 7078 DUMP2("back to caller (caller thread:%lx)", thread); 7079 DUMP2(" (current thread:%lx)", rb_thread_current()); 7080#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 7081 have_rb_thread_waiting_for_value = 1; 7082 rb_thread_wakeup(thread); 7083#else 7084 rb_thread_run(thread); 7085#endif 7086 DUMP1("finish back to caller"); 7087#if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 7088 rb_thread_schedule(); 7089#endif 7090 } else { 7091 DUMP2("caller is dead (caller thread:%lx)", thread); 7092 DUMP2(" (current thread:%lx)", rb_thread_current()); 7093 } 7094 7095 /* end of handler : remove it */ 7096 return 1; 7097} 7098 7099static VALUE 7100tk_funcall(func, argc, argv, obj) 7101 VALUE (*func)(); 7102 int argc; 7103 VALUE *argv; 7104 VALUE obj; 7105{ 7106 struct call_queue *callq; 7107 struct tcltkip *ptr; 7108 int *alloc_done; 7109 int thr_crit_bup; 7110 int is_tk_evloop_thread; 7111 volatile VALUE current = rb_thread_current(); 7112 volatile VALUE ip_obj = obj; 7113 volatile VALUE result; 7114 volatile VALUE ret; 7115 struct timeval t; 7116 7117 if (!NIL_P(ip_obj) && rb_obj_is_kind_of(ip_obj, tcltkip_class)) { 7118 ptr = get_ip(ip_obj); 7119 if (deleted_ip(ptr)) return Qnil; 7120 } else { 7121 ptr = (struct tcltkip *)NULL; 7122 } 7123 7124#ifdef RUBY_USE_NATIVE_THREAD 7125 if (ptr) { 7126 /* on Tcl interpreter */ 7127 is_tk_evloop_thread = (ptr->tk_thread_id == (Tcl_ThreadId) 0 7128 || ptr->tk_thread_id == Tcl_GetCurrentThread()); 7129 } else { 7130 /* on Tcl/Tk library */ 7131 is_tk_evloop_thread = (tk_eventloop_thread_id == (Tcl_ThreadId) 0 7132 || tk_eventloop_thread_id == Tcl_GetCurrentThread()); 7133 } 7134#else 7135 is_tk_evloop_thread = 1; 7136#endif 7137 7138 if (is_tk_evloop_thread 7139 && (NIL_P(eventloop_thread) || current == eventloop_thread) 7140 ) { 7141 if (NIL_P(eventloop_thread)) { 7142 DUMP2("tk_funcall from thread:%lx but no eventloop", current); 7143 } else { 7144 DUMP2("tk_funcall from current eventloop %lx", current); 7145 } 7146 result = (func)(ip_obj, argc, argv); 7147 if (rb_obj_is_kind_of(result, rb_eException)) { 7148 rb_exc_raise(result); 7149 } 7150 return result; 7151 } 7152 7153 DUMP2("tk_funcall from thread %lx (NOT current eventloop)", current); 7154 7155 thr_crit_bup = rb_thread_critical; 7156 rb_thread_critical = Qtrue; 7157 7158 /* allocate memory (argv cross over thread : must be in heap) */ 7159 if (argv) { 7160 /* VALUE *temp = ALLOC_N(VALUE, argc); */ 7161 VALUE *temp = RbTk_ALLOC_N(VALUE, argc); 7162#if 0 /* use Tcl_Preserve/Release */ 7163 Tcl_Preserve((ClientData)temp); /* XXXXXXXX */ 7164#endif 7165 MEMCPY(temp, argv, VALUE, argc); 7166 argv = temp; 7167 } 7168 7169 /* allocate memory (keep result) */ 7170 /* alloc_done = (int*)ALLOC(int); */ 7171 alloc_done = RbTk_ALLOC_N(int, 1); 7172#if 0 /* use Tcl_Preserve/Release */ 7173 Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */ 7174#endif 7175 *alloc_done = 0; 7176 7177 /* allocate memory (freed by Tcl_ServiceEvent) */ 7178 /* callq = (struct call_queue *)Tcl_Alloc(sizeof(struct call_queue)); */ 7179 callq = RbTk_ALLOC_N(struct call_queue, 1); 7180#if 0 /* use Tcl_Preserve/Release */ 7181 Tcl_Preserve(callq); 7182#endif 7183 7184 /* allocate result obj */ 7185 result = rb_ary_new3(1, Qnil); 7186 7187 /* construct event data */ 7188 callq->done = alloc_done; 7189 callq->func = func; 7190 callq->argc = argc; 7191 callq->argv = argv; 7192 callq->interp = ip_obj; 7193 callq->result = result; 7194 callq->thread = current; 7195 callq->safe_level = rb_safe_level(); 7196 callq->ev.proc = call_queue_handler; 7197 7198 /* add the handler to Tcl event queue */ 7199 DUMP1("add handler"); 7200#ifdef RUBY_USE_NATIVE_THREAD 7201 if (ptr && ptr->tk_thread_id) { 7202 /* Tcl_ThreadQueueEvent(ptr->tk_thread_id, 7203 &(callq->ev), TCL_QUEUE_HEAD); */ 7204 Tcl_ThreadQueueEvent(ptr->tk_thread_id, 7205 (Tcl_Event*)callq, TCL_QUEUE_HEAD); 7206 Tcl_ThreadAlert(ptr->tk_thread_id); 7207 } else if (tk_eventloop_thread_id) { 7208 /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id, 7209 &(callq->ev), TCL_QUEUE_HEAD); */ 7210 Tcl_ThreadQueueEvent(tk_eventloop_thread_id, 7211 (Tcl_Event*)callq, TCL_QUEUE_HEAD); 7212 Tcl_ThreadAlert(tk_eventloop_thread_id); 7213 } else { 7214 /* Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); */ 7215 Tcl_QueueEvent((Tcl_Event*)callq, TCL_QUEUE_HEAD); 7216 } 7217#else 7218 /* Tcl_QueueEvent(&(callq->ev), TCL_QUEUE_HEAD); */ 7219 Tcl_QueueEvent((Tcl_Event*)callq, TCL_QUEUE_HEAD); 7220#endif 7221 7222 rb_thread_critical = thr_crit_bup; 7223 7224 /* wait for the handler to be processed */ 7225 t.tv_sec = 0; 7226 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0); 7227 7228 DUMP2("callq wait for handler (current thread:%lx)", current); 7229 while(*alloc_done >= 0) { 7230 DUMP2("*** callq wait for handler (current thread:%lx)", current); 7231 /* rb_thread_stop(); */ 7232 /* rb_thread_sleep_forever(); */ 7233 rb_thread_wait_for(t); 7234 DUMP2("*** callq wakeup (current thread:%lx)", current); 7235 DUMP2("*** (eventloop thread:%lx)", eventloop_thread); 7236 if (NIL_P(eventloop_thread)) { 7237 DUMP1("*** callq lost eventloop thread"); 7238 break; 7239 } 7240 } 7241 DUMP2("back from handler (current thread:%lx)", current); 7242 7243 /* get result & free allocated memory */ 7244 ret = RARRAY_PTR(result)[0]; 7245#if 0 /* use Tcl_EventuallyFree */ 7246 Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */ 7247#else 7248#if 0 /* use Tcl_Preserve/Release */ 7249 Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */ 7250#else 7251 /* free(alloc_done); */ 7252 ckfree((char*)alloc_done); 7253#endif 7254#endif 7255 /* if (argv) free(argv); */ 7256 if (argv) { 7257 /* if argv != NULL, alloc as 'temp' */ 7258 int i; 7259 for(i = 0; i < argc; i++) { argv[i] = (VALUE)NULL; } 7260 7261#if 0 /* use Tcl_EventuallyFree */ 7262 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ 7263#else 7264#if 0 /* use Tcl_Preserve/Release */ 7265 Tcl_Release((ClientData)argv); /* XXXXXXXX */ 7266#else 7267 ckfree((char*)argv); 7268#endif 7269#endif 7270 } 7271 7272#if 0 /* callq is freed by Tcl_ServiceEvent */ 7273#if 0 /* use Tcl_Preserve/Release */ 7274 Tcl_Release(callq); 7275#else 7276 ckfree((char*)callq); 7277#endif 7278#endif 7279 7280 /* exception? */ 7281 if (rb_obj_is_kind_of(ret, rb_eException)) { 7282 DUMP1("raise exception"); 7283 /* rb_exc_raise(ret); */ 7284 rb_exc_raise(rb_exc_new3(rb_obj_class(ret), 7285 rb_funcall(ret, ID_to_s, 0, 0))); 7286 } 7287 7288 DUMP1("exit tk_funcall"); 7289 return ret; 7290} 7291 7292 7293/* eval string in tcl by Tcl_Eval() */ 7294#if TCL_MAJOR_VERSION >= 8 7295struct call_eval_info { 7296 struct tcltkip *ptr; 7297 Tcl_Obj *cmd; 7298}; 7299 7300static VALUE 7301#ifdef HAVE_PROTOTYPES 7302call_tcl_eval(VALUE arg) 7303#else 7304call_tcl_eval(arg) 7305 VALUE arg; 7306#endif 7307{ 7308 struct call_eval_info *inf = (struct call_eval_info *)arg; 7309 7310 Tcl_AllowExceptions(inf->ptr->ip); 7311 inf->ptr->return_value = Tcl_EvalObj(inf->ptr->ip, inf->cmd); 7312 7313 return Qnil; 7314} 7315#endif 7316 7317static VALUE 7318ip_eval_real(self, cmd_str, cmd_len) 7319 VALUE self; 7320 char *cmd_str; 7321 int cmd_len; 7322{ 7323 volatile VALUE ret; 7324 struct tcltkip *ptr = get_ip(self); 7325 int thr_crit_bup; 7326 7327#if TCL_MAJOR_VERSION >= 8 7328 /* call Tcl_EvalObj() */ 7329 { 7330 Tcl_Obj *cmd; 7331 7332 thr_crit_bup = rb_thread_critical; 7333 rb_thread_critical = Qtrue; 7334 7335 cmd = Tcl_NewStringObj(cmd_str, cmd_len); 7336 Tcl_IncrRefCount(cmd); 7337 7338 /* ip is deleted? */ 7339 if (deleted_ip(ptr)) { 7340 Tcl_DecrRefCount(cmd); 7341 rb_thread_critical = thr_crit_bup; 7342 ptr->return_value = TCL_OK; 7343 return rb_tainted_str_new2(""); 7344 } else { 7345 int status; 7346 struct call_eval_info inf; 7347 7348 /* Tcl_Preserve(ptr->ip); */ 7349 rbtk_preserve_ip(ptr); 7350 7351#if 0 7352 ptr->return_value = Tcl_EvalObj(ptr->ip, cmd); 7353 /* ptr->return_value = Tcl_GlobalEvalObj(ptr->ip, cmd); */ 7354#else 7355 inf.ptr = ptr; 7356 inf.cmd = cmd; 7357 ret = rb_protect(call_tcl_eval, (VALUE)&inf, &status); 7358 switch(status) { 7359 case TAG_RAISE: 7360 if (NIL_P(rb_errinfo())) { 7361 rbtk_pending_exception = rb_exc_new2(rb_eException, 7362 "unknown exception"); 7363 } else { 7364 rbtk_pending_exception = rb_errinfo(); 7365 } 7366 break; 7367 7368 case TAG_FATAL: 7369 if (NIL_P(rb_errinfo())) { 7370 rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL"); 7371 } else { 7372 rbtk_pending_exception = rb_errinfo(); 7373 } 7374 } 7375#endif 7376 } 7377 7378 Tcl_DecrRefCount(cmd); 7379 7380 } 7381 7382 if (pending_exception_check1(thr_crit_bup, ptr)) { 7383 rbtk_release_ip(ptr); 7384 return rbtk_pending_exception; 7385 } 7386 7387 /* if (ptr->return_value == TCL_ERROR) { */ 7388 if (ptr->return_value != TCL_OK) { 7389 if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) { 7390 volatile VALUE exc; 7391 7392 switch (ptr->return_value) { 7393 case TCL_RETURN: 7394 exc = create_ip_exc(self, eTkCallbackReturn, 7395 "ip_eval_real receives TCL_RETURN"); 7396 case TCL_BREAK: 7397 exc = create_ip_exc(self, eTkCallbackBreak, 7398 "ip_eval_real receives TCL_BREAK"); 7399 case TCL_CONTINUE: 7400 exc = create_ip_exc(self, eTkCallbackContinue, 7401 "ip_eval_real receives TCL_CONTINUE"); 7402 default: 7403 exc = create_ip_exc(self, rb_eRuntimeError, "%s", 7404 Tcl_GetStringResult(ptr->ip)); 7405 } 7406 7407 rbtk_release_ip(ptr); 7408 rb_thread_critical = thr_crit_bup; 7409 return exc; 7410 } else { 7411 if (event_loop_abort_on_exc < 0) { 7412 rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip)); 7413 } else { 7414 rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip)); 7415 } 7416 Tcl_ResetResult(ptr->ip); 7417 rbtk_release_ip(ptr); 7418 rb_thread_critical = thr_crit_bup; 7419 return rb_tainted_str_new2(""); 7420 } 7421 } 7422 7423 /* pass back the result (as string) */ 7424 ret = ip_get_result_string_obj(ptr->ip); 7425 rbtk_release_ip(ptr); 7426 rb_thread_critical = thr_crit_bup; 7427 return ret; 7428 7429#else /* TCL_MAJOR_VERSION < 8 */ 7430 DUMP2("Tcl_Eval(%s)", cmd_str); 7431 7432 /* ip is deleted? */ 7433 if (deleted_ip(ptr)) { 7434 ptr->return_value = TCL_OK; 7435 return rb_tainted_str_new2(""); 7436 } else { 7437 /* Tcl_Preserve(ptr->ip); */ 7438 rbtk_preserve_ip(ptr); 7439 ptr->return_value = Tcl_Eval(ptr->ip, cmd_str); 7440 /* ptr->return_value = Tcl_GlobalEval(ptr->ip, cmd_str); */ 7441 } 7442 7443 if (pending_exception_check1(thr_crit_bup, ptr)) { 7444 rbtk_release_ip(ptr); 7445 return rbtk_pending_exception; 7446 } 7447 7448 /* if (ptr->return_value == TCL_ERROR) { */ 7449 if (ptr->return_value != TCL_OK) { 7450 volatile VALUE exc; 7451 7452 switch (ptr->return_value) { 7453 case TCL_RETURN: 7454 exc = create_ip_exc(self, eTkCallbackReturn, 7455 "ip_eval_real receives TCL_RETURN"); 7456 case TCL_BREAK: 7457 exc = create_ip_exc(self, eTkCallbackBreak, 7458 "ip_eval_real receives TCL_BREAK"); 7459 case TCL_CONTINUE: 7460 exc = create_ip_exc(self, eTkCallbackContinue, 7461 "ip_eval_real receives TCL_CONTINUE"); 7462 default: 7463 exc = create_ip_exc(self, rb_eRuntimeError, "%s", ptr->ip->result); 7464 } 7465 7466 rbtk_release_ip(ptr); 7467 return exc; 7468 } 7469 DUMP2("(TCL_Eval result) %d", ptr->return_value); 7470 7471 /* pass back the result (as string) */ 7472 ret = ip_get_result_string_obj(ptr->ip); 7473 rbtk_release_ip(ptr); 7474 return ret; 7475#endif 7476} 7477 7478static VALUE 7479evq_safelevel_handler(arg, evq) 7480 VALUE arg; 7481 VALUE evq; 7482{ 7483 struct eval_queue *q; 7484 7485 Data_Get_Struct(evq, struct eval_queue, q); 7486 DUMP2("(safe-level handler) $SAFE = %d", q->safe_level); 7487 rb_set_safe_level(q->safe_level); 7488 return ip_eval_real(q->interp, q->str, q->len); 7489} 7490 7491int eval_queue_handler _((Tcl_Event *, int)); 7492int 7493eval_queue_handler(evPtr, flags) 7494 Tcl_Event *evPtr; 7495 int flags; 7496{ 7497 struct eval_queue *q = (struct eval_queue *)evPtr; 7498 volatile VALUE ret; 7499 volatile VALUE q_dat; 7500 volatile VALUE thread = q->thread; 7501 struct tcltkip *ptr; 7502 7503 DUMP2("do_eval_queue_handler : evPtr = %p", evPtr); 7504 DUMP2("eval_queue_thread : %lx", rb_thread_current()); 7505 DUMP2("added by thread : %lx", thread); 7506 7507 if (*(q->done)) { 7508 DUMP1("processed by another event-loop"); 7509 return 0; 7510 } else { 7511 DUMP1("process it on current event-loop"); 7512 } 7513 7514#ifdef RUBY_VM 7515 if (RTEST(rb_funcall(thread, ID_alive_p, 0)) 7516 && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) { 7517#else 7518 if (RTEST(rb_thread_alive_p(thread)) 7519 && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) { 7520#endif 7521 DUMP1("caller is not yet ready to receive the result -> pending"); 7522 return 0; 7523 } 7524 7525 /* process it */ 7526 *(q->done) = 1; 7527 7528 /* deleted ipterp ? */ 7529 ptr = get_ip(q->interp); 7530 if (deleted_ip(ptr)) { 7531 /* deleted IP --> ignore */ 7532 return 1; 7533 } 7534 7535 /* incr internal handler mark */ 7536 rbtk_internal_eventloop_handler++; 7537 7538 /* check safe-level */ 7539 if (rb_safe_level() != q->safe_level) { 7540#ifdef HAVE_NATIVETHREAD 7541#ifndef RUBY_USE_NATIVE_THREAD 7542 if (!ruby_native_thread_p()) { 7543 rb_bug("cross-thread violation on eval_queue_handler()"); 7544 } 7545#endif 7546#endif 7547 /* q_dat = Data_Wrap_Struct(rb_cData,0,-1,q); */ 7548 q_dat = Data_Wrap_Struct(rb_cData,eval_queue_mark,-1,q); 7549 ret = rb_funcall(rb_proc_new(evq_safelevel_handler, q_dat), 7550 ID_call, 0); 7551 rb_gc_force_recycle(q_dat); 7552 q_dat = (VALUE)NULL; 7553 } else { 7554 ret = ip_eval_real(q->interp, q->str, q->len); 7555 } 7556 7557 /* set result */ 7558 RARRAY_PTR(q->result)[0] = ret; 7559 ret = (VALUE)NULL; 7560 7561 /* decr internal handler mark */ 7562 rbtk_internal_eventloop_handler--; 7563 7564 /* complete */ 7565 *(q->done) = -1; 7566 7567 /* unlink ruby objects */ 7568 q->interp = (VALUE)NULL; 7569 q->result = (VALUE)NULL; 7570 q->thread = (VALUE)NULL; 7571 7572 /* back to caller */ 7573#ifdef RUBY_VM 7574 if (RTEST(rb_funcall(thread, ID_alive_p, 0, 0))) { 7575#else 7576 if (RTEST(rb_thread_alive_p(thread))) { 7577#endif 7578 DUMP2("back to caller (caller thread:%lx)", thread); 7579 DUMP2(" (current thread:%lx)", rb_thread_current()); 7580#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 7581 have_rb_thread_waiting_for_value = 1; 7582 rb_thread_wakeup(thread); 7583#else 7584 rb_thread_run(thread); 7585#endif 7586 DUMP1("finish back to caller"); 7587#if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 7588 rb_thread_schedule(); 7589#endif 7590 } else { 7591 DUMP2("caller is dead (caller thread:%lx)", thread); 7592 DUMP2(" (current thread:%lx)", rb_thread_current()); 7593 } 7594 7595 /* end of handler : remove it */ 7596 return 1; 7597} 7598 7599static VALUE 7600ip_eval(self, str) 7601 VALUE self; 7602 VALUE str; 7603{ 7604 struct eval_queue *evq; 7605#ifdef RUBY_USE_NATIVE_THREAD 7606 struct tcltkip *ptr; 7607#endif 7608 char *eval_str; 7609 int *alloc_done; 7610 int thr_crit_bup; 7611 volatile VALUE current = rb_thread_current(); 7612 volatile VALUE ip_obj = self; 7613 volatile VALUE result; 7614 volatile VALUE ret; 7615 Tcl_QueuePosition position; 7616 struct timeval t; 7617 7618 thr_crit_bup = rb_thread_critical; 7619 rb_thread_critical = Qtrue; 7620 StringValue(str); 7621 rb_thread_critical = thr_crit_bup; 7622 7623#ifdef RUBY_USE_NATIVE_THREAD 7624 ptr = get_ip(ip_obj); 7625 DUMP2("eval status: ptr->tk_thread_id %p", ptr->tk_thread_id); 7626 DUMP2("eval status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread()); 7627#else 7628 DUMP2("status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread()); 7629#endif 7630 DUMP2("status: eventloopt_thread %lx", eventloop_thread); 7631 7632 if ( 7633#ifdef RUBY_USE_NATIVE_THREAD 7634 (ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread()) 7635 && 7636#endif 7637 (NIL_P(eventloop_thread) || current == eventloop_thread) 7638 ) { 7639 if (NIL_P(eventloop_thread)) { 7640 DUMP2("eval from thread:%lx but no eventloop", current); 7641 } else { 7642 DUMP2("eval from current eventloop %lx", current); 7643 } 7644 result = ip_eval_real(self, RSTRING_PTR(str), RSTRING_LENINT(str)); 7645 if (rb_obj_is_kind_of(result, rb_eException)) { 7646 rb_exc_raise(result); 7647 } 7648 return result; 7649 } 7650 7651 DUMP2("eval from thread %lx (NOT current eventloop)", current); 7652 7653 thr_crit_bup = rb_thread_critical; 7654 rb_thread_critical = Qtrue; 7655 7656 /* allocate memory (keep result) */ 7657 /* alloc_done = (int*)ALLOC(int); */ 7658 alloc_done = RbTk_ALLOC_N(int, 1); 7659#if 0 /* use Tcl_Preserve/Release */ 7660 Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */ 7661#endif 7662 *alloc_done = 0; 7663 7664 /* eval_str = ALLOC_N(char, RSTRING_LEN(str) + 1); */ 7665 eval_str = ckalloc(RSTRING_LENINT(str) + 1); 7666#if 0 /* use Tcl_Preserve/Release */ 7667 Tcl_Preserve((ClientData)eval_str); /* XXXXXXXX */ 7668#endif 7669 memcpy(eval_str, RSTRING_PTR(str), RSTRING_LEN(str)); 7670 eval_str[RSTRING_LEN(str)] = 0; 7671 7672 /* allocate memory (freed by Tcl_ServiceEvent) */ 7673 /* evq = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue)); */ 7674 evq = RbTk_ALLOC_N(struct eval_queue, 1); 7675#if 0 /* use Tcl_Preserve/Release */ 7676 Tcl_Preserve(evq); 7677#endif 7678 7679 /* allocate result obj */ 7680 result = rb_ary_new3(1, Qnil); 7681 7682 /* construct event data */ 7683 evq->done = alloc_done; 7684 evq->str = eval_str; 7685 evq->len = RSTRING_LENINT(str); 7686 evq->interp = ip_obj; 7687 evq->result = result; 7688 evq->thread = current; 7689 evq->safe_level = rb_safe_level(); 7690 evq->ev.proc = eval_queue_handler; 7691 7692 position = TCL_QUEUE_TAIL; 7693 7694 /* add the handler to Tcl event queue */ 7695 DUMP1("add handler"); 7696#ifdef RUBY_USE_NATIVE_THREAD 7697 if (ptr->tk_thread_id) { 7698 /* Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(evq->ev), position); */ 7699 Tcl_ThreadQueueEvent(ptr->tk_thread_id, (Tcl_Event*)evq, position); 7700 Tcl_ThreadAlert(ptr->tk_thread_id); 7701 } else if (tk_eventloop_thread_id) { 7702 Tcl_ThreadQueueEvent(tk_eventloop_thread_id, (Tcl_Event*)evq, position); 7703 /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id, 7704 &(evq->ev), position); */ 7705 Tcl_ThreadAlert(tk_eventloop_thread_id); 7706 } else { 7707 /* Tcl_QueueEvent(&(evq->ev), position); */ 7708 Tcl_QueueEvent((Tcl_Event*)evq, position); 7709 } 7710#else 7711 /* Tcl_QueueEvent(&(evq->ev), position); */ 7712 Tcl_QueueEvent((Tcl_Event*)evq, position); 7713#endif 7714 7715 rb_thread_critical = thr_crit_bup; 7716 7717 /* wait for the handler to be processed */ 7718 t.tv_sec = 0; 7719 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0); 7720 7721 DUMP2("evq wait for handler (current thread:%lx)", current); 7722 while(*alloc_done >= 0) { 7723 DUMP2("*** evq wait for handler (current thread:%lx)", current); 7724 /* rb_thread_stop(); */ 7725 /* rb_thread_sleep_forever(); */ 7726 rb_thread_wait_for(t); 7727 DUMP2("*** evq wakeup (current thread:%lx)", current); 7728 DUMP2("*** (eventloop thread:%lx)", eventloop_thread); 7729 if (NIL_P(eventloop_thread)) { 7730 DUMP1("*** evq lost eventloop thread"); 7731 break; 7732 } 7733 } 7734 DUMP2("back from handler (current thread:%lx)", current); 7735 7736 /* get result & free allocated memory */ 7737 ret = RARRAY_PTR(result)[0]; 7738 7739#if 0 /* use Tcl_EventuallyFree */ 7740 Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */ 7741#else 7742#if 0 /* use Tcl_Preserve/Release */ 7743 Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */ 7744#else 7745 /* free(alloc_done); */ 7746 ckfree((char*)alloc_done); 7747#endif 7748#endif 7749#if 0 /* use Tcl_EventuallyFree */ 7750 Tcl_EventuallyFree((ClientData)eval_str, TCL_DYNAMIC); /* XXXXXXXX */ 7751#else 7752#if 0 /* use Tcl_Preserve/Release */ 7753 Tcl_Release((ClientData)eval_str); /* XXXXXXXX */ 7754#else 7755 /* free(eval_str); */ 7756 ckfree(eval_str); 7757#endif 7758#endif 7759#if 0 /* evq is freed by Tcl_ServiceEvent */ 7760#if 0 /* use Tcl_Preserve/Release */ 7761 Tcl_Release(evq); 7762#else 7763 ckfree((char*)evq); 7764#endif 7765#endif 7766 7767 if (rb_obj_is_kind_of(ret, rb_eException)) { 7768 DUMP1("raise exception"); 7769 /* rb_exc_raise(ret); */ 7770 rb_exc_raise(rb_exc_new3(rb_obj_class(ret), 7771 rb_funcall(ret, ID_to_s, 0, 0))); 7772 } 7773 7774 return ret; 7775} 7776 7777 7778static int 7779ip_cancel_eval_core(interp, msg, flag) 7780 Tcl_Interp *interp; 7781 VALUE msg; 7782 int flag; 7783{ 7784#if TCL_MAJOR_VERSION < 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 6) 7785 rb_raise(rb_eNotImpError, 7786 "cancel_eval is supported Tcl/Tk8.6 or later."); 7787 7788 UNREACHABLE; 7789#else 7790 Tcl_Obj *msg_obj; 7791 7792 if (NIL_P(msg)) { 7793 msg_obj = NULL; 7794 } else { 7795 msg_obj = Tcl_NewStringObj(RSTRING_PTR(msg), RSTRING_LEN(msg)); 7796 Tcl_IncrRefCount(msg_obj); 7797 } 7798 7799 return Tcl_CancelEval(interp, msg_obj, 0, flag); 7800#endif 7801} 7802 7803static VALUE 7804ip_cancel_eval(argc, argv, self) 7805 int argc; 7806 VALUE *argv; 7807 VALUE self; 7808{ 7809 VALUE retval; 7810 7811 if (rb_scan_args(argc, argv, "01", &retval) == 0) { 7812 retval = Qnil; 7813 } 7814 if (ip_cancel_eval_core(get_ip(self)->ip, retval, 0) == TCL_OK) { 7815 return Qtrue; 7816 } else { 7817 return Qfalse; 7818 } 7819} 7820 7821#ifndef TCL_CANCEL_UNWIND 7822#define TCL_CANCEL_UNWIND 0x100000 7823#endif 7824static VALUE 7825ip_cancel_eval_unwind(argc, argv, self) 7826 int argc; 7827 VALUE *argv; 7828 VALUE self; 7829{ 7830 int flag = 0; 7831 VALUE retval; 7832 7833 if (rb_scan_args(argc, argv, "01", &retval) == 0) { 7834 retval = Qnil; 7835 } 7836 7837 flag |= TCL_CANCEL_UNWIND; 7838 if (ip_cancel_eval_core(get_ip(self)->ip, retval, flag) == TCL_OK) { 7839 return Qtrue; 7840 } else { 7841 return Qfalse; 7842 } 7843} 7844 7845/* restart Tk */ 7846static VALUE 7847lib_restart_core(interp, argc, argv) 7848 VALUE interp; 7849 int argc; /* dummy */ 7850 VALUE *argv; /* dummy */ 7851{ 7852 volatile VALUE exc; 7853 struct tcltkip *ptr = get_ip(interp); 7854 int thr_crit_bup; 7855 7856 /* rb_secure(4); */ /* already checked */ 7857 7858 /* tcl_stubs_check(); */ /* already checked */ 7859 7860 /* ip is deleted? */ 7861 if (deleted_ip(ptr)) { 7862 return rb_exc_new2(rb_eRuntimeError, "interpreter is deleted"); 7863 } 7864 7865 thr_crit_bup = rb_thread_critical; 7866 rb_thread_critical = Qtrue; 7867 7868 /* Tcl_Preserve(ptr->ip); */ 7869 rbtk_preserve_ip(ptr); 7870 7871 /* destroy the root wdiget */ 7872 ptr->return_value = Tcl_Eval(ptr->ip, "destroy ."); 7873 /* ignore ERROR */ 7874 DUMP2("(TCL_Eval result) %d", ptr->return_value); 7875 Tcl_ResetResult(ptr->ip); 7876 7877#if TCL_MAJOR_VERSION >= 8 7878 /* delete namespace ( tested on tk8.4.5 ) */ 7879 ptr->return_value = Tcl_Eval(ptr->ip, "namespace delete ::tk::msgcat"); 7880 /* ignore ERROR */ 7881 DUMP2("(TCL_Eval result) %d", ptr->return_value); 7882 Tcl_ResetResult(ptr->ip); 7883#endif 7884 7885 /* delete trace proc ( tested on tk8.4.5 ) */ 7886 ptr->return_value = Tcl_Eval(ptr->ip, "trace vdelete ::tk_strictMotif w ::tk::EventMotifBindings"); 7887 /* ignore ERROR */ 7888 DUMP2("(TCL_Eval result) %d", ptr->return_value); 7889 Tcl_ResetResult(ptr->ip); 7890 7891 /* execute Tk_Init or Tk_SafeInit */ 7892 exc = tcltkip_init_tk(interp); 7893 if (!NIL_P(exc)) { 7894 rb_thread_critical = thr_crit_bup; 7895 rbtk_release_ip(ptr); 7896 return exc; 7897 } 7898 7899 /* Tcl_Release(ptr->ip); */ 7900 rbtk_release_ip(ptr); 7901 7902 rb_thread_critical = thr_crit_bup; 7903 7904 /* return Qnil; */ 7905 return interp; 7906} 7907 7908static VALUE 7909lib_restart(self) 7910 VALUE self; 7911{ 7912 struct tcltkip *ptr = get_ip(self); 7913 7914 rb_secure(4); 7915 7916 tcl_stubs_check(); 7917 7918 /* ip is deleted? */ 7919 if (deleted_ip(ptr)) { 7920 rb_raise(rb_eRuntimeError, "interpreter is deleted"); 7921 } 7922 7923 return tk_funcall(lib_restart_core, 0, (VALUE*)NULL, self); 7924} 7925 7926 7927static VALUE 7928ip_restart(self) 7929 VALUE self; 7930{ 7931 struct tcltkip *ptr = get_ip(self); 7932 7933 rb_secure(4); 7934 7935 tcl_stubs_check(); 7936 7937 /* ip is deleted? */ 7938 if (deleted_ip(ptr)) { 7939 rb_raise(rb_eRuntimeError, "interpreter is deleted"); 7940 } 7941 7942 if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) { 7943 /* slave IP */ 7944 return Qnil; 7945 } 7946 return lib_restart(self); 7947} 7948 7949static VALUE 7950lib_toUTF8_core(ip_obj, src, encodename) 7951 VALUE ip_obj; 7952 VALUE src; 7953 VALUE encodename; 7954{ 7955 volatile VALUE str = src; 7956 7957#ifdef TCL_UTF_MAX 7958 Tcl_Interp *interp; 7959 Tcl_Encoding encoding; 7960 Tcl_DString dstr; 7961 int taint_flag = OBJ_TAINTED(str); 7962 struct tcltkip *ptr; 7963 char *buf; 7964 int thr_crit_bup; 7965#endif 7966 7967 tcl_stubs_check(); 7968 7969 if (NIL_P(src)) { 7970 return rb_str_new2(""); 7971 } 7972 7973#ifdef TCL_UTF_MAX 7974 if (NIL_P(ip_obj)) { 7975 interp = (Tcl_Interp *)NULL; 7976 } else { 7977 ptr = get_ip(ip_obj); 7978 7979 /* ip is deleted? */ 7980 if (deleted_ip(ptr)) { 7981 interp = (Tcl_Interp *)NULL; 7982 } else { 7983 interp = ptr->ip; 7984 } 7985 } 7986 7987 thr_crit_bup = rb_thread_critical; 7988 rb_thread_critical = Qtrue; 7989 7990 if (NIL_P(encodename)) { 7991 if (TYPE(str) == T_STRING) { 7992 volatile VALUE enc; 7993 7994#ifdef HAVE_RUBY_ENCODING_H 7995 enc = rb_funcall(rb_obj_encoding(str), ID_to_s, 0, 0); 7996#else 7997 enc = rb_attr_get(str, ID_at_enc); 7998#endif 7999 if (NIL_P(enc)) { 8000 if (NIL_P(ip_obj)) { 8001 encoding = (Tcl_Encoding)NULL; 8002 } else { 8003 enc = rb_attr_get(ip_obj, ID_at_enc); 8004 if (NIL_P(enc)) { 8005 encoding = (Tcl_Encoding)NULL; 8006 } else { 8007 /* StringValue(enc); */ 8008 enc = rb_funcall(enc, ID_to_s, 0, 0); 8009 /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */ 8010 if (!RSTRING_LEN(enc)) { 8011 encoding = (Tcl_Encoding)NULL; 8012 } else { 8013 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, 8014 RSTRING_PTR(enc)); 8015 if (encoding == (Tcl_Encoding)NULL) { 8016 rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc)); 8017 } 8018 } 8019 } 8020 } 8021 } else { 8022 StringValue(enc); 8023 if (strcmp(RSTRING_PTR(enc), "binary") == 0) { 8024#ifdef HAVE_RUBY_ENCODING_H 8025 rb_enc_associate_index(str, ENCODING_INDEX_BINARY); 8026#endif 8027 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY); 8028 rb_thread_critical = thr_crit_bup; 8029 return str; 8030 } 8031 /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */ 8032 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, 8033 RSTRING_PTR(enc)); 8034 if (encoding == (Tcl_Encoding)NULL) { 8035 rb_warning("string has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc)); 8036 } 8037 } 8038 } else { 8039 encoding = (Tcl_Encoding)NULL; 8040 } 8041 } else { 8042 StringValue(encodename); 8043 if (strcmp(RSTRING_PTR(encodename), "binary") == 0) { 8044#ifdef HAVE_RUBY_ENCODING_H 8045 rb_enc_associate_index(str, ENCODING_INDEX_BINARY); 8046#endif 8047 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY); 8048 rb_thread_critical = thr_crit_bup; 8049 return str; 8050 } 8051 /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(encodename)); */ 8052 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(encodename)); 8053 if (encoding == (Tcl_Encoding)NULL) { 8054 /* 8055 rb_warning("unknown encoding name '%s'", 8056 RSTRING_PTR(encodename)); 8057 */ 8058 rb_raise(rb_eArgError, "unknown encoding name '%s'", 8059 RSTRING_PTR(encodename)); 8060 } 8061 } 8062 8063 StringValue(str); 8064 if (!RSTRING_LEN(str)) { 8065 rb_thread_critical = thr_crit_bup; 8066 return str; 8067 } 8068 buf = ALLOC_N(char, RSTRING_LEN(str)+1); 8069 /* buf = ckalloc(sizeof(char) * (RSTRING_LENINT(str)+1)); */ 8070 memcpy(buf, RSTRING_PTR(str), RSTRING_LEN(str)); 8071 buf[RSTRING_LEN(str)] = 0; 8072 8073 Tcl_DStringInit(&dstr); 8074 Tcl_DStringFree(&dstr); 8075 /* Tcl_ExternalToUtfDString(encoding,buf,strlen(buf),&dstr); */ 8076 Tcl_ExternalToUtfDString(encoding, buf, RSTRING_LENINT(str), &dstr); 8077 8078 /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */ 8079 /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */ 8080 str = rb_str_new(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr)); 8081#ifdef HAVE_RUBY_ENCODING_H 8082 rb_enc_associate_index(str, ENCODING_INDEX_UTF8); 8083#endif 8084 if (taint_flag) RbTk_OBJ_UNTRUST(str); 8085 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8); 8086 8087 /* 8088 if (encoding != (Tcl_Encoding)NULL) { 8089 Tcl_FreeEncoding(encoding); 8090 } 8091 */ 8092 Tcl_DStringFree(&dstr); 8093 8094 xfree(buf); 8095 /* ckfree(buf); */ 8096 8097 rb_thread_critical = thr_crit_bup; 8098#endif 8099 8100 return str; 8101} 8102 8103static VALUE 8104lib_toUTF8(argc, argv, self) 8105 int argc; 8106 VALUE *argv; 8107 VALUE self; 8108{ 8109 VALUE str, encodename; 8110 8111 if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) { 8112 encodename = Qnil; 8113 } 8114 return lib_toUTF8_core(Qnil, str, encodename); 8115} 8116 8117static VALUE 8118ip_toUTF8(argc, argv, self) 8119 int argc; 8120 VALUE *argv; 8121 VALUE self; 8122{ 8123 VALUE str, encodename; 8124 8125 if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) { 8126 encodename = Qnil; 8127 } 8128 return lib_toUTF8_core(self, str, encodename); 8129} 8130 8131static VALUE 8132lib_fromUTF8_core(ip_obj, src, encodename) 8133 VALUE ip_obj; 8134 VALUE src; 8135 VALUE encodename; 8136{ 8137 volatile VALUE str = src; 8138 8139#ifdef TCL_UTF_MAX 8140 Tcl_Interp *interp; 8141 Tcl_Encoding encoding; 8142 Tcl_DString dstr; 8143 int taint_flag = OBJ_TAINTED(str); 8144 char *buf; 8145 int thr_crit_bup; 8146#endif 8147 8148 tcl_stubs_check(); 8149 8150 if (NIL_P(src)) { 8151 return rb_str_new2(""); 8152 } 8153 8154#ifdef TCL_UTF_MAX 8155 if (NIL_P(ip_obj)) { 8156 interp = (Tcl_Interp *)NULL; 8157 } else if (get_ip(ip_obj) == (struct tcltkip *)NULL) { 8158 interp = (Tcl_Interp *)NULL; 8159 } else { 8160 interp = get_ip(ip_obj)->ip; 8161 } 8162 8163 thr_crit_bup = rb_thread_critical; 8164 rb_thread_critical = Qtrue; 8165 8166 if (NIL_P(encodename)) { 8167 volatile VALUE enc; 8168 8169 if (TYPE(str) == T_STRING) { 8170 enc = rb_attr_get(str, ID_at_enc); 8171 if (!NIL_P(enc)) { 8172 StringValue(enc); 8173 if (strcmp(RSTRING_PTR(enc), "binary") == 0) { 8174#ifdef HAVE_RUBY_ENCODING_H 8175 rb_enc_associate_index(str, ENCODING_INDEX_BINARY); 8176#endif 8177 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY); 8178 rb_thread_critical = thr_crit_bup; 8179 return str; 8180 } 8181#ifdef HAVE_RUBY_ENCODING_H 8182 } else if (rb_enc_get_index(str) == ENCODING_INDEX_BINARY) { 8183 rb_enc_associate_index(str, ENCODING_INDEX_BINARY); 8184 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY); 8185 rb_thread_critical = thr_crit_bup; 8186 return str; 8187#endif 8188 } 8189 } 8190 8191 if (NIL_P(ip_obj)) { 8192 encoding = (Tcl_Encoding)NULL; 8193 } else { 8194 enc = rb_attr_get(ip_obj, ID_at_enc); 8195 if (NIL_P(enc)) { 8196 encoding = (Tcl_Encoding)NULL; 8197 } else { 8198 /* StringValue(enc); */ 8199 enc = rb_funcall(enc, ID_to_s, 0, 0); 8200 /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(enc)); */ 8201 if (!RSTRING_LEN(enc)) { 8202 encoding = (Tcl_Encoding)NULL; 8203 } else { 8204 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, 8205 RSTRING_PTR(enc)); 8206 if (encoding == (Tcl_Encoding)NULL) { 8207 rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING_PTR(enc)); 8208 } else { 8209 encodename = rb_obj_dup(enc); 8210 } 8211 } 8212 } 8213 } 8214 8215 } else { 8216 StringValue(encodename); 8217 8218 if (strcmp(RSTRING_PTR(encodename), "binary") == 0) { 8219 Tcl_Obj *tclstr; 8220 char *s; 8221 int len; 8222 8223 StringValue(str); 8224 tclstr = Tcl_NewStringObj(RSTRING_PTR(str), RSTRING_LENINT(str)); 8225 Tcl_IncrRefCount(tclstr); 8226 s = (char*)Tcl_GetByteArrayFromObj(tclstr, &len); 8227 str = rb_tainted_str_new(s, len); 8228 s = (char*)NULL; 8229 Tcl_DecrRefCount(tclstr); 8230#ifdef HAVE_RUBY_ENCODING_H 8231 rb_enc_associate_index(str, ENCODING_INDEX_BINARY); 8232#endif 8233 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_BINARY); 8234 8235 rb_thread_critical = thr_crit_bup; 8236 return str; 8237 } 8238 8239 /* encoding = Tcl_GetEncoding(interp, RSTRING_PTR(encodename)); */ 8240 encoding = Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(encodename)); 8241 if (encoding == (Tcl_Encoding)NULL) { 8242 /* 8243 rb_warning("unknown encoding name '%s'", 8244 RSTRING_PTR(encodename)); 8245 encodename = Qnil; 8246 */ 8247 rb_raise(rb_eArgError, "unknown encoding name '%s'", 8248 RSTRING_PTR(encodename)); 8249 } 8250 } 8251 8252 StringValue(str); 8253 8254 if (RSTRING_LEN(str) == 0) { 8255 rb_thread_critical = thr_crit_bup; 8256 return rb_tainted_str_new2(""); 8257 } 8258 8259 buf = ALLOC_N(char, RSTRING_LEN(str)+1); 8260 /* buf = ckalloc(sizeof(char) * (RSTRING_LENINT(str)+1)); */ 8261 memcpy(buf, RSTRING_PTR(str), RSTRING_LEN(str)); 8262 buf[RSTRING_LEN(str)] = 0; 8263 8264 Tcl_DStringInit(&dstr); 8265 Tcl_DStringFree(&dstr); 8266 /* Tcl_UtfToExternalDString(encoding,buf,strlen(buf),&dstr); */ 8267 Tcl_UtfToExternalDString(encoding,buf,RSTRING_LENINT(str),&dstr); 8268 8269 /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */ 8270 /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */ 8271 str = rb_str_new(Tcl_DStringValue(&dstr), Tcl_DStringLength(&dstr)); 8272#ifdef HAVE_RUBY_ENCODING_H 8273 if (interp) { 8274 /* can access encoding_table of TclTkIp */ 8275 /* -> try to use encoding_table */ 8276 VALUE tbl = ip_get_encoding_table(ip_obj); 8277 VALUE encobj = encoding_table_get_obj(tbl, encodename); 8278 rb_enc_associate_index(str, rb_to_encoding_index(encobj)); 8279 } else { 8280 /* cannot access encoding_table of TclTkIp */ 8281 /* -> try to find on Ruby Encoding */ 8282 rb_enc_associate_index(str, rb_enc_find_index(RSTRING_PTR(encodename))); 8283 } 8284#endif 8285 8286 if (taint_flag) RbTk_OBJ_UNTRUST(str); 8287 rb_ivar_set(str, ID_at_enc, encodename); 8288 8289 /* 8290 if (encoding != (Tcl_Encoding)NULL) { 8291 Tcl_FreeEncoding(encoding); 8292 } 8293 */ 8294 Tcl_DStringFree(&dstr); 8295 8296 xfree(buf); 8297 /* ckfree(buf); */ 8298 8299 rb_thread_critical = thr_crit_bup; 8300#endif 8301 8302 return str; 8303} 8304 8305static VALUE 8306lib_fromUTF8(argc, argv, self) 8307 int argc; 8308 VALUE *argv; 8309 VALUE self; 8310{ 8311 VALUE str, encodename; 8312 8313 if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) { 8314 encodename = Qnil; 8315 } 8316 return lib_fromUTF8_core(Qnil, str, encodename); 8317} 8318 8319static VALUE 8320ip_fromUTF8(argc, argv, self) 8321 int argc; 8322 VALUE *argv; 8323 VALUE self; 8324{ 8325 VALUE str, encodename; 8326 8327 if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) { 8328 encodename = Qnil; 8329 } 8330 return lib_fromUTF8_core(self, str, encodename); 8331} 8332 8333static VALUE 8334lib_UTF_backslash_core(self, str, all_bs) 8335 VALUE self; 8336 VALUE str; 8337 int all_bs; 8338{ 8339#ifdef TCL_UTF_MAX 8340 char *src_buf, *dst_buf, *ptr; 8341 int read_len = 0, dst_len = 0; 8342 int taint_flag = OBJ_TAINTED(str); 8343 int thr_crit_bup; 8344 8345 tcl_stubs_check(); 8346 8347 StringValue(str); 8348 if (!RSTRING_LEN(str)) { 8349 return str; 8350 } 8351 8352 thr_crit_bup = rb_thread_critical; 8353 rb_thread_critical = Qtrue; 8354 8355 /* src_buf = ALLOC_N(char, RSTRING_LEN(str)+1); */ 8356 src_buf = ckalloc(RSTRING_LENINT(str)+1); 8357#if 0 /* use Tcl_Preserve/Release */ 8358 Tcl_Preserve((ClientData)src_buf); /* XXXXXXXX */ 8359#endif 8360 memcpy(src_buf, RSTRING_PTR(str), RSTRING_LEN(str)); 8361 src_buf[RSTRING_LEN(str)] = 0; 8362 8363 /* dst_buf = ALLOC_N(char, RSTRING_LEN(str)+1); */ 8364 dst_buf = ckalloc(RSTRING_LENINT(str)+1); 8365#if 0 /* use Tcl_Preserve/Release */ 8366 Tcl_Preserve((ClientData)dst_buf); /* XXXXXXXX */ 8367#endif 8368 8369 ptr = src_buf; 8370 while(RSTRING_LEN(str) > ptr - src_buf) { 8371 if (*ptr == '\\' && (all_bs || *(ptr + 1) == 'u')) { 8372 dst_len += Tcl_UtfBackslash(ptr, &read_len, (dst_buf + dst_len)); 8373 ptr += read_len; 8374 } else { 8375 *(dst_buf + (dst_len++)) = *(ptr++); 8376 } 8377 } 8378 8379 str = rb_str_new(dst_buf, dst_len); 8380 if (taint_flag) RbTk_OBJ_UNTRUST(str); 8381#ifdef HAVE_RUBY_ENCODING_H 8382 rb_enc_associate_index(str, ENCODING_INDEX_UTF8); 8383#endif 8384 rb_ivar_set(str, ID_at_enc, ENCODING_NAME_UTF8); 8385 8386#if 0 /* use Tcl_EventuallyFree */ 8387 Tcl_EventuallyFree((ClientData)src_buf, TCL_DYNAMIC); /* XXXXXXXX */ 8388#else 8389#if 0 /* use Tcl_Preserve/Release */ 8390 Tcl_Release((ClientData)src_buf); /* XXXXXXXX */ 8391#else 8392 /* free(src_buf); */ 8393 ckfree(src_buf); 8394#endif 8395#endif 8396#if 0 /* use Tcl_EventuallyFree */ 8397 Tcl_EventuallyFree((ClientData)dst_buf, TCL_DYNAMIC); /* XXXXXXXX */ 8398#else 8399#if 0 /* use Tcl_Preserve/Release */ 8400 Tcl_Release((ClientData)dst_buf); /* XXXXXXXX */ 8401#else 8402 /* free(dst_buf); */ 8403 ckfree(dst_buf); 8404#endif 8405#endif 8406 8407 rb_thread_critical = thr_crit_bup; 8408#endif 8409 8410 return str; 8411} 8412 8413static VALUE 8414lib_UTF_backslash(self, str) 8415 VALUE self; 8416 VALUE str; 8417{ 8418 return lib_UTF_backslash_core(self, str, 0); 8419} 8420 8421static VALUE 8422lib_Tcl_backslash(self, str) 8423 VALUE self; 8424 VALUE str; 8425{ 8426 return lib_UTF_backslash_core(self, str, 1); 8427} 8428 8429static VALUE 8430lib_get_system_encoding(self) 8431 VALUE self; 8432{ 8433#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0) 8434 tcl_stubs_check(); 8435 return rb_str_new2(Tcl_GetEncodingName((Tcl_Encoding)NULL)); 8436#else 8437 return Qnil; 8438#endif 8439} 8440 8441static VALUE 8442lib_set_system_encoding(self, enc_name) 8443 VALUE self; 8444 VALUE enc_name; 8445{ 8446#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0) 8447 tcl_stubs_check(); 8448 8449 if (NIL_P(enc_name)) { 8450 Tcl_SetSystemEncoding((Tcl_Interp *)NULL, (CONST char *)NULL); 8451 return lib_get_system_encoding(self); 8452 } 8453 8454 enc_name = rb_funcall(enc_name, ID_to_s, 0, 0); 8455 if (Tcl_SetSystemEncoding((Tcl_Interp *)NULL, 8456 StringValuePtr(enc_name)) != TCL_OK) { 8457 rb_raise(rb_eArgError, "unknown encoding name '%s'", 8458 RSTRING_PTR(enc_name)); 8459 } 8460 8461 return enc_name; 8462#else 8463 return Qnil; 8464#endif 8465} 8466 8467 8468/* invoke Tcl proc */ 8469struct invoke_info { 8470 struct tcltkip *ptr; 8471 Tcl_CmdInfo cmdinfo; 8472#if TCL_MAJOR_VERSION >= 8 8473 int objc; 8474 Tcl_Obj **objv; 8475#else 8476 int argc; 8477 char **argv; 8478#endif 8479}; 8480 8481static VALUE 8482#ifdef HAVE_PROTOTYPES 8483invoke_tcl_proc(VALUE arg) 8484#else 8485invoke_tcl_proc(arg) 8486 VALUE arg; 8487#endif 8488{ 8489 struct invoke_info *inf = (struct invoke_info *)arg; 8490 int i, len; 8491#if TCL_MAJOR_VERSION >= 8 8492 int argc = inf->objc; 8493 char **argv = (char **)NULL; 8494#endif 8495 8496 /* memory allocation for arguments of this command */ 8497#if TCL_MAJOR_VERSION >= 8 8498 if (!inf->cmdinfo.isNativeObjectProc) { 8499 /* string interface */ 8500 /* argv = (char **)ALLOC_N(char *, argc+1);*/ /* XXXXXXXXXX */ 8501 argv = RbTk_ALLOC_N(char *, (argc+1)); 8502#if 0 /* use Tcl_Preserve/Release */ 8503 Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ 8504#endif 8505 for (i = 0; i < argc; ++i) { 8506 argv[i] = Tcl_GetStringFromObj(inf->objv[i], &len); 8507 } 8508 argv[argc] = (char *)NULL; 8509 } 8510#endif 8511 8512 Tcl_ResetResult(inf->ptr->ip); 8513 8514 /* Invoke the C procedure */ 8515#if TCL_MAJOR_VERSION >= 8 8516 if (inf->cmdinfo.isNativeObjectProc) { 8517 inf->ptr->return_value 8518 = (*(inf->cmdinfo.objProc))(inf->cmdinfo.objClientData, 8519 inf->ptr->ip, inf->objc, inf->objv); 8520 } 8521 else 8522#endif 8523 { 8524#if TCL_MAJOR_VERSION >= 8 8525 inf->ptr->return_value 8526 = (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip, 8527 argc, (CONST84 char **)argv); 8528 8529#if 0 /* use Tcl_EventuallyFree */ 8530 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ 8531#else 8532#if 0 /* use Tcl_Preserve/Release */ 8533 Tcl_Release((ClientData)argv); /* XXXXXXXX */ 8534#else 8535 /* free(argv); */ 8536 ckfree((char*)argv); 8537#endif 8538#endif 8539 8540#else /* TCL_MAJOR_VERSION < 8 */ 8541 inf->ptr->return_value 8542 = (*(inf->cmdinfo.proc))(inf->cmdinfo.clientData, inf->ptr->ip, 8543 inf->argc, inf->argv); 8544#endif 8545 } 8546 8547 return Qnil; 8548} 8549 8550 8551#if TCL_MAJOR_VERSION >= 8 8552static VALUE 8553ip_invoke_core(interp, objc, objv) 8554 VALUE interp; 8555 int objc; 8556 Tcl_Obj **objv; 8557#else 8558static VALUE 8559ip_invoke_core(interp, argc, argv) 8560 VALUE interp; 8561 int argc; 8562 char **argv; 8563#endif 8564{ 8565 struct tcltkip *ptr; 8566 Tcl_CmdInfo info; 8567 char *cmd; 8568 int len; 8569 int thr_crit_bup; 8570 int unknown_flag = 0; 8571 8572#if 1 /* wrap tcl-proc call */ 8573 struct invoke_info inf; 8574 int status; 8575 VALUE ret; 8576#else 8577#if TCL_MAJOR_VERSION >= 8 8578 int argc = objc; 8579 char **argv = (char **)NULL; 8580 /* Tcl_Obj *resultPtr; */ 8581#endif 8582#endif 8583 8584 /* get the data struct */ 8585 ptr = get_ip(interp); 8586 8587 /* get the command name string */ 8588#if TCL_MAJOR_VERSION >= 8 8589 cmd = Tcl_GetStringFromObj(objv[0], &len); 8590#else /* TCL_MAJOR_VERSION < 8 */ 8591 cmd = argv[0]; 8592#endif 8593 8594 /* get the data struct */ 8595 ptr = get_ip(interp); 8596 8597 /* ip is deleted? */ 8598 if (deleted_ip(ptr)) { 8599 return rb_tainted_str_new2(""); 8600 } 8601 8602 /* Tcl_Preserve(ptr->ip); */ 8603 rbtk_preserve_ip(ptr); 8604 8605 /* map from the command name to a C procedure */ 8606 DUMP2("call Tcl_GetCommandInfo, %s", cmd); 8607 if (!Tcl_GetCommandInfo(ptr->ip, cmd, &info)) { 8608 DUMP1("error Tcl_GetCommandInfo"); 8609 DUMP1("try auto_load (call 'unknown' command)"); 8610 if (!Tcl_GetCommandInfo(ptr->ip, 8611#if TCL_MAJOR_VERSION >= 8 8612 "::unknown", 8613#else 8614 "unknown", 8615#endif 8616 &info)) { 8617 DUMP1("fail to get 'unknown' command"); 8618 /* if (event_loop_abort_on_exc || cmd[0] != '.') { */ 8619 if (event_loop_abort_on_exc > 0) { 8620 /* Tcl_Release(ptr->ip); */ 8621 rbtk_release_ip(ptr); 8622 /*rb_ip_raise(obj,rb_eNameError,"invalid command name `%s'",cmd);*/ 8623 return create_ip_exc(interp, rb_eNameError, 8624 "invalid command name `%s'", cmd); 8625 } else { 8626 if (event_loop_abort_on_exc < 0) { 8627 rb_warning("invalid command name `%s' (ignore)", cmd); 8628 } else { 8629 rb_warn("invalid command name `%s' (ignore)", cmd); 8630 } 8631 Tcl_ResetResult(ptr->ip); 8632 /* Tcl_Release(ptr->ip); */ 8633 rbtk_release_ip(ptr); 8634 return rb_tainted_str_new2(""); 8635 } 8636 } else { 8637#if TCL_MAJOR_VERSION >= 8 8638 Tcl_Obj **unknown_objv; 8639#else 8640 char **unknown_argv; 8641#endif 8642 DUMP1("find 'unknown' command -> set arguemnts"); 8643 unknown_flag = 1; 8644 8645#if TCL_MAJOR_VERSION >= 8 8646 /* unknown_objv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, objc+2); */ 8647 unknown_objv = RbTk_ALLOC_N(Tcl_Obj *, (objc+2)); 8648#if 0 /* use Tcl_Preserve/Release */ 8649 Tcl_Preserve((ClientData)unknown_objv); /* XXXXXXXX */ 8650#endif 8651 unknown_objv[0] = Tcl_NewStringObj("::unknown", 9); 8652 Tcl_IncrRefCount(unknown_objv[0]); 8653 memcpy(unknown_objv + 1, objv, sizeof(Tcl_Obj *)*objc); 8654 unknown_objv[++objc] = (Tcl_Obj*)NULL; 8655 objv = unknown_objv; 8656#else 8657 /* unknown_argv = (char **)ALLOC_N(char *, argc+2); */ 8658 unknown_argv = RbTk_ALLOC_N(char *, (argc+2)); 8659#if 0 /* use Tcl_Preserve/Release */ 8660 Tcl_Preserve((ClientData)unknown_argv); /* XXXXXXXX */ 8661#endif 8662 unknown_argv[0] = strdup("unknown"); 8663 memcpy(unknown_argv + 1, argv, sizeof(char *)*argc); 8664 unknown_argv[++argc] = (char *)NULL; 8665 argv = unknown_argv; 8666#endif 8667 } 8668 } 8669 DUMP1("end Tcl_GetCommandInfo"); 8670 8671 thr_crit_bup = rb_thread_critical; 8672 rb_thread_critical = Qtrue; 8673 8674#if 1 /* wrap tcl-proc call */ 8675 /* setup params */ 8676 inf.ptr = ptr; 8677 inf.cmdinfo = info; 8678#if TCL_MAJOR_VERSION >= 8 8679 inf.objc = objc; 8680 inf.objv = objv; 8681#else 8682 inf.argc = argc; 8683 inf.argv = argv; 8684#endif 8685 8686 /* invoke tcl-proc */ 8687 ret = rb_protect(invoke_tcl_proc, (VALUE)&inf, &status); 8688 switch(status) { 8689 case TAG_RAISE: 8690 if (NIL_P(rb_errinfo())) { 8691 rbtk_pending_exception = rb_exc_new2(rb_eException, 8692 "unknown exception"); 8693 } else { 8694 rbtk_pending_exception = rb_errinfo(); 8695 } 8696 break; 8697 8698 case TAG_FATAL: 8699 if (NIL_P(rb_errinfo())) { 8700 rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL"); 8701 } else { 8702 rbtk_pending_exception = rb_errinfo(); 8703 } 8704 } 8705 8706#else /* !wrap tcl-proc call */ 8707 8708 /* memory allocation for arguments of this command */ 8709#if TCL_MAJOR_VERSION >= 8 8710 if (!info.isNativeObjectProc) { 8711 int i; 8712 8713 /* string interface */ 8714 /* argv = (char **)ALLOC_N(char *, argc+1); */ 8715 argv = RbTk_ALLOC_N(char *, (argc+1)); 8716#if 0 /* use Tcl_Preserve/Release */ 8717 Tcl_Preserve((ClientData)argv); /* XXXXXXXX */ 8718#endif 8719 for (i = 0; i < argc; ++i) { 8720 argv[i] = Tcl_GetStringFromObj(objv[i], &len); 8721 } 8722 argv[argc] = (char *)NULL; 8723 } 8724#endif 8725 8726 Tcl_ResetResult(ptr->ip); 8727 8728 /* Invoke the C procedure */ 8729#if TCL_MAJOR_VERSION >= 8 8730 if (info.isNativeObjectProc) { 8731 ptr->return_value = (*info.objProc)(info.objClientData, ptr->ip, 8732 objc, objv); 8733#if 0 8734 /* get the string value from the result object */ 8735 resultPtr = Tcl_GetObjResult(ptr->ip); 8736 Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &len), 8737 TCL_VOLATILE); 8738#endif 8739 } 8740 else 8741#endif 8742 { 8743#if TCL_MAJOR_VERSION >= 8 8744 ptr->return_value = (*info.proc)(info.clientData, ptr->ip, 8745 argc, (CONST84 char **)argv); 8746 8747#if 0 /* use Tcl_EventuallyFree */ 8748 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ 8749#else 8750#if 0 /* use Tcl_Preserve/Release */ 8751 Tcl_Release((ClientData)argv); /* XXXXXXXX */ 8752#else 8753 /* free(argv); */ 8754 ckfree((char*)argv); 8755#endif 8756#endif 8757 8758#else /* TCL_MAJOR_VERSION < 8 */ 8759 ptr->return_value = (*info.proc)(info.clientData, ptr->ip, 8760 argc, argv); 8761#endif 8762 } 8763#endif /* ! wrap tcl-proc call */ 8764 8765 /* free allocated memory for calling 'unknown' command */ 8766 if (unknown_flag) { 8767#if TCL_MAJOR_VERSION >= 8 8768 Tcl_DecrRefCount(objv[0]); 8769#if 0 /* use Tcl_EventuallyFree */ 8770 Tcl_EventuallyFree((ClientData)objv, TCL_DYNAMIC); /* XXXXXXXX */ 8771#else 8772#if 0 /* use Tcl_Preserve/Release */ 8773 Tcl_Release((ClientData)objv); /* XXXXXXXX */ 8774#else 8775 /* free(objv); */ 8776 ckfree((char*)objv); 8777#endif 8778#endif 8779#else /* TCL_MAJOR_VERSION < 8 */ 8780 free(argv[0]); 8781 /* ckfree(argv[0]); */ 8782#if 0 /* use Tcl_EventuallyFree */ 8783 Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */ 8784#else 8785#if 0 /* use Tcl_Preserve/Release */ 8786 Tcl_Release((ClientData)argv); /* XXXXXXXX */ 8787#else 8788 /* free(argv); */ 8789 ckfree((char*)argv); 8790#endif 8791#endif 8792#endif 8793 } 8794 8795 /* exception on mainloop */ 8796 if (pending_exception_check1(thr_crit_bup, ptr)) { 8797 return rbtk_pending_exception; 8798 } 8799 8800 rb_thread_critical = thr_crit_bup; 8801 8802 /* if (ptr->return_value == TCL_ERROR) { */ 8803 if (ptr->return_value != TCL_OK) { 8804 if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) { 8805 switch (ptr->return_value) { 8806 case TCL_RETURN: 8807 return create_ip_exc(interp, eTkCallbackReturn, 8808 "ip_invoke_core receives TCL_RETURN"); 8809 case TCL_BREAK: 8810 return create_ip_exc(interp, eTkCallbackBreak, 8811 "ip_invoke_core receives TCL_BREAK"); 8812 case TCL_CONTINUE: 8813 return create_ip_exc(interp, eTkCallbackContinue, 8814 "ip_invoke_core receives TCL_CONTINUE"); 8815 default: 8816 return create_ip_exc(interp, rb_eRuntimeError, "%s", 8817 Tcl_GetStringResult(ptr->ip)); 8818 } 8819 8820 } else { 8821 if (event_loop_abort_on_exc < 0) { 8822 rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip)); 8823 } else { 8824 rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip)); 8825 } 8826 Tcl_ResetResult(ptr->ip); 8827 return rb_tainted_str_new2(""); 8828 } 8829 } 8830 8831 /* pass back the result (as string) */ 8832 return ip_get_result_string_obj(ptr->ip); 8833} 8834 8835 8836#if TCL_MAJOR_VERSION >= 8 8837static Tcl_Obj ** 8838#else /* TCL_MAJOR_VERSION < 8 */ 8839static char ** 8840#endif 8841alloc_invoke_arguments(argc, argv) 8842 int argc; 8843 VALUE *argv; 8844{ 8845 int i; 8846 int thr_crit_bup; 8847 8848#if TCL_MAJOR_VERSION >= 8 8849 Tcl_Obj **av; 8850#else /* TCL_MAJOR_VERSION < 8 */ 8851 char **av; 8852#endif 8853 8854 thr_crit_bup = rb_thread_critical; 8855 rb_thread_critical = Qtrue; 8856 8857 /* memory allocation */ 8858#if TCL_MAJOR_VERSION >= 8 8859 /* av = ALLOC_N(Tcl_Obj *, argc+1);*/ /* XXXXXXXXXX */ 8860 av = RbTk_ALLOC_N(Tcl_Obj *, (argc+1)); 8861#if 0 /* use Tcl_Preserve/Release */ 8862 Tcl_Preserve((ClientData)av); /* XXXXXXXX */ 8863#endif 8864 for (i = 0; i < argc; ++i) { 8865 av[i] = get_obj_from_str(argv[i]); 8866 Tcl_IncrRefCount(av[i]); 8867 } 8868 av[argc] = NULL; 8869 8870#else /* TCL_MAJOR_VERSION < 8 */ 8871 /* string interface */ 8872 /* av = ALLOC_N(char *, argc+1); */ 8873 av = RbTk_ALLOC_N(char *, (argc+1)); 8874#if 0 /* use Tcl_Preserve/Release */ 8875 Tcl_Preserve((ClientData)av); /* XXXXXXXX */ 8876#endif 8877 for (i = 0; i < argc; ++i) { 8878 av[i] = strdup(StringValuePtr(argv[i])); 8879 } 8880 av[argc] = NULL; 8881#endif 8882 8883 rb_thread_critical = thr_crit_bup; 8884 8885 return av; 8886} 8887 8888static void 8889free_invoke_arguments(argc, av) 8890 int argc; 8891#if TCL_MAJOR_VERSION >= 8 8892 Tcl_Obj **av; 8893#else /* TCL_MAJOR_VERSION < 8 */ 8894 char **av; 8895#endif 8896{ 8897 int i; 8898 8899 for (i = 0; i < argc; ++i) { 8900#if TCL_MAJOR_VERSION >= 8 8901 Tcl_DecrRefCount(av[i]); 8902 av[i] = (Tcl_Obj*)NULL; 8903#else /* TCL_MAJOR_VERSION < 8 */ 8904 free(av[i]); 8905 av[i] = (char*)NULL; 8906#endif 8907 } 8908#if TCL_MAJOR_VERSION >= 8 8909#if 0 /* use Tcl_EventuallyFree */ 8910 Tcl_EventuallyFree((ClientData)av, TCL_DYNAMIC); /* XXXXXXXX */ 8911#else 8912#if 0 /* use Tcl_Preserve/Release */ 8913 Tcl_Release((ClientData)av); /* XXXXXXXX */ 8914#else 8915 ckfree((char*)av); 8916#endif 8917#endif 8918#else /* TCL_MAJOR_VERSION < 8 */ 8919#if 0 /* use Tcl_EventuallyFree */ 8920 Tcl_EventuallyFree((ClientData)av, TCL_DYNAMIC); /* XXXXXXXX */ 8921#else 8922#if 0 /* use Tcl_Preserve/Release */ 8923 Tcl_Release((ClientData)av); /* XXXXXXXX */ 8924#else 8925 /* free(av); */ 8926 ckfree((char*)av); 8927#endif 8928#endif 8929#endif 8930} 8931 8932static VALUE 8933ip_invoke_real(argc, argv, interp) 8934 int argc; 8935 VALUE *argv; 8936 VALUE interp; 8937{ 8938 VALUE v; 8939 struct tcltkip *ptr; /* tcltkip data struct */ 8940 8941#if TCL_MAJOR_VERSION >= 8 8942 Tcl_Obj **av = (Tcl_Obj **)NULL; 8943#else /* TCL_MAJOR_VERSION < 8 */ 8944 char **av = (char **)NULL; 8945#endif 8946 8947 DUMP2("invoke_real called by thread:%lx", rb_thread_current()); 8948 8949 /* get the data struct */ 8950 ptr = get_ip(interp); 8951 8952 /* ip is deleted? */ 8953 if (deleted_ip(ptr)) { 8954 return rb_tainted_str_new2(""); 8955 } 8956 8957 /* allocate memory for arguments */ 8958 av = alloc_invoke_arguments(argc, argv); 8959 8960 /* Invoke the C procedure */ 8961 Tcl_ResetResult(ptr->ip); 8962 v = ip_invoke_core(interp, argc, av); 8963 8964 /* free allocated memory */ 8965 free_invoke_arguments(argc, av); 8966 8967 return v; 8968} 8969 8970VALUE 8971ivq_safelevel_handler(arg, ivq) 8972 VALUE arg; 8973 VALUE ivq; 8974{ 8975 struct invoke_queue *q; 8976 8977 Data_Get_Struct(ivq, struct invoke_queue, q); 8978 DUMP2("(safe-level handler) $SAFE = %d", q->safe_level); 8979 rb_set_safe_level(q->safe_level); 8980 return ip_invoke_core(q->interp, q->argc, q->argv); 8981} 8982 8983int invoke_queue_handler _((Tcl_Event *, int)); 8984int 8985invoke_queue_handler(evPtr, flags) 8986 Tcl_Event *evPtr; 8987 int flags; 8988{ 8989 struct invoke_queue *q = (struct invoke_queue *)evPtr; 8990 volatile VALUE ret; 8991 volatile VALUE q_dat; 8992 volatile VALUE thread = q->thread; 8993 struct tcltkip *ptr; 8994 8995 DUMP2("do_invoke_queue_handler : evPtr = %p", evPtr); 8996 DUMP2("invoke queue_thread : %lx", rb_thread_current()); 8997 DUMP2("added by thread : %lx", thread); 8998 8999 if (*(q->done)) { 9000 DUMP1("processed by another event-loop"); 9001 return 0; 9002 } else { 9003 DUMP1("process it on current event-loop"); 9004 } 9005 9006#ifdef RUBY_VM 9007 if (RTEST(rb_funcall(thread, ID_alive_p, 0)) 9008 && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) { 9009#else 9010 if (RTEST(rb_thread_alive_p(thread)) 9011 && ! RTEST(rb_funcall(thread, ID_stop_p, 0))) { 9012#endif 9013 DUMP1("caller is not yet ready to receive the result -> pending"); 9014 return 0; 9015 } 9016 9017 /* process it */ 9018 *(q->done) = 1; 9019 9020 /* deleted ipterp ? */ 9021 ptr = get_ip(q->interp); 9022 if (deleted_ip(ptr)) { 9023 /* deleted IP --> ignore */ 9024 return 1; 9025 } 9026 9027 /* incr internal handler mark */ 9028 rbtk_internal_eventloop_handler++; 9029 9030 /* check safe-level */ 9031 if (rb_safe_level() != q->safe_level) { 9032 /* q_dat = Data_Wrap_Struct(rb_cData,0,0,q); */ 9033 q_dat = Data_Wrap_Struct(rb_cData,invoke_queue_mark,-1,q); 9034 ret = rb_funcall(rb_proc_new(ivq_safelevel_handler, q_dat), 9035 ID_call, 0); 9036 rb_gc_force_recycle(q_dat); 9037 q_dat = (VALUE)NULL; 9038 } else { 9039 DUMP2("call invoke_real (for caller thread:%lx)", thread); 9040 DUMP2("call invoke_real (current thread:%lx)", rb_thread_current()); 9041 ret = ip_invoke_core(q->interp, q->argc, q->argv); 9042 } 9043 9044 /* set result */ 9045 RARRAY_PTR(q->result)[0] = ret; 9046 ret = (VALUE)NULL; 9047 9048 /* decr internal handler mark */ 9049 rbtk_internal_eventloop_handler--; 9050 9051 /* complete */ 9052 *(q->done) = -1; 9053 9054 /* unlink ruby objects */ 9055 q->interp = (VALUE)NULL; 9056 q->result = (VALUE)NULL; 9057 q->thread = (VALUE)NULL; 9058 9059 /* back to caller */ 9060#ifdef RUBY_VM 9061 if (RTEST(rb_funcall(thread, ID_alive_p, 0, 0))) { 9062#else 9063 if (RTEST(rb_thread_alive_p(thread))) { 9064#endif 9065 DUMP2("back to caller (caller thread:%lx)", thread); 9066 DUMP2(" (current thread:%lx)", rb_thread_current()); 9067#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE 9068 have_rb_thread_waiting_for_value = 1; 9069 rb_thread_wakeup(thread); 9070#else 9071 rb_thread_run(thread); 9072#endif 9073 DUMP1("finish back to caller"); 9074#if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE 9075 rb_thread_schedule(); 9076#endif 9077 } else { 9078 DUMP2("caller is dead (caller thread:%lx)", thread); 9079 DUMP2(" (current thread:%lx)", rb_thread_current()); 9080 } 9081 9082 /* end of handler : remove it */ 9083 return 1; 9084} 9085 9086static VALUE 9087ip_invoke_with_position(argc, argv, obj, position) 9088 int argc; 9089 VALUE *argv; 9090 VALUE obj; 9091 Tcl_QueuePosition position; 9092{ 9093 struct invoke_queue *ivq; 9094#ifdef RUBY_USE_NATIVE_THREAD 9095 struct tcltkip *ptr; 9096#endif 9097 int *alloc_done; 9098 int thr_crit_bup; 9099 volatile VALUE current = rb_thread_current(); 9100 volatile VALUE ip_obj = obj; 9101 volatile VALUE result; 9102 volatile VALUE ret; 9103 struct timeval t; 9104 9105#if TCL_MAJOR_VERSION >= 8 9106 Tcl_Obj **av = (Tcl_Obj **)NULL; 9107#else /* TCL_MAJOR_VERSION < 8 */ 9108 char **av = (char **)NULL; 9109#endif 9110 9111 if (argc < 1) { 9112 rb_raise(rb_eArgError, "command name missing"); 9113 } 9114 9115#ifdef RUBY_USE_NATIVE_THREAD 9116 ptr = get_ip(ip_obj); 9117 DUMP2("invoke status: ptr->tk_thread_id %p", ptr->tk_thread_id); 9118 DUMP2("invoke status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread()); 9119#else 9120 DUMP2("status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread()); 9121#endif 9122 DUMP2("status: eventloopt_thread %lx", eventloop_thread); 9123 9124 if ( 9125#ifdef RUBY_USE_NATIVE_THREAD 9126 (ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread()) 9127 && 9128#endif 9129 (NIL_P(eventloop_thread) || current == eventloop_thread) 9130 ) { 9131 if (NIL_P(eventloop_thread)) { 9132 DUMP2("invoke from thread:%lx but no eventloop", current); 9133 } else { 9134 DUMP2("invoke from current eventloop %lx", current); 9135 } 9136 result = ip_invoke_real(argc, argv, ip_obj); 9137 if (rb_obj_is_kind_of(result, rb_eException)) { 9138 rb_exc_raise(result); 9139 } 9140 return result; 9141 } 9142 9143 DUMP2("invoke from thread %lx (NOT current eventloop)", current); 9144 9145 thr_crit_bup = rb_thread_critical; 9146 rb_thread_critical = Qtrue; 9147 9148 /* allocate memory (for arguments) */ 9149 av = alloc_invoke_arguments(argc, argv); 9150 9151 /* allocate memory (keep result) */ 9152 /* alloc_done = (int*)ALLOC(int); */ 9153 alloc_done = RbTk_ALLOC_N(int, 1); 9154#if 0 /* use Tcl_Preserve/Release */ 9155 Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */ 9156#endif 9157 *alloc_done = 0; 9158 9159 /* allocate memory (freed by Tcl_ServiceEvent) */ 9160 /* ivq = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue)); */ 9161 ivq = RbTk_ALLOC_N(struct invoke_queue, 1); 9162#if 0 /* use Tcl_Preserve/Release */ 9163 Tcl_Preserve((ClientData)ivq); /* XXXXXXXX */ 9164#endif 9165 9166 /* allocate result obj */ 9167 result = rb_ary_new3(1, Qnil); 9168 9169 /* construct event data */ 9170 ivq->done = alloc_done; 9171 ivq->argc = argc; 9172 ivq->argv = av; 9173 ivq->interp = ip_obj; 9174 ivq->result = result; 9175 ivq->thread = current; 9176 ivq->safe_level = rb_safe_level(); 9177 ivq->ev.proc = invoke_queue_handler; 9178 9179 /* add the handler to Tcl event queue */ 9180 DUMP1("add handler"); 9181#ifdef RUBY_USE_NATIVE_THREAD 9182 if (ptr->tk_thread_id) { 9183 /* Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(ivq->ev), position); */ 9184 Tcl_ThreadQueueEvent(ptr->tk_thread_id, (Tcl_Event*)ivq, position); 9185 Tcl_ThreadAlert(ptr->tk_thread_id); 9186 } else if (tk_eventloop_thread_id) { 9187 /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id, 9188 &(ivq->ev), position); */ 9189 Tcl_ThreadQueueEvent(tk_eventloop_thread_id, 9190 (Tcl_Event*)ivq, position); 9191 Tcl_ThreadAlert(tk_eventloop_thread_id); 9192 } else { 9193 /* Tcl_QueueEvent(&(ivq->ev), position); */ 9194 Tcl_QueueEvent((Tcl_Event*)ivq, position); 9195 } 9196#else 9197 /* Tcl_QueueEvent(&(ivq->ev), position); */ 9198 Tcl_QueueEvent((Tcl_Event*)ivq, position); 9199#endif 9200 9201 rb_thread_critical = thr_crit_bup; 9202 9203 /* wait for the handler to be processed */ 9204 t.tv_sec = 0; 9205 t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0); 9206 9207 DUMP2("ivq wait for handler (current thread:%lx)", current); 9208 while(*alloc_done >= 0) { 9209 /* rb_thread_stop(); */ 9210 /* rb_thread_sleep_forever(); */ 9211 rb_thread_wait_for(t); 9212 DUMP2("*** ivq wakeup (current thread:%lx)", current); 9213 DUMP2("*** (eventloop thread:%lx)", eventloop_thread); 9214 if (NIL_P(eventloop_thread)) { 9215 DUMP1("*** ivq lost eventloop thread"); 9216 break; 9217 } 9218 } 9219 DUMP2("back from handler (current thread:%lx)", current); 9220 9221 /* get result & free allocated memory */ 9222 ret = RARRAY_PTR(result)[0]; 9223#if 0 /* use Tcl_EventuallyFree */ 9224 Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */ 9225#else 9226#if 0 /* use Tcl_Preserve/Release */ 9227 Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */ 9228#else 9229 /* free(alloc_done); */ 9230 ckfree((char*)alloc_done); 9231#endif 9232#endif 9233 9234#if 0 /* ivq is freed by Tcl_ServiceEvent */ 9235#if 0 /* use Tcl_EventuallyFree */ 9236 Tcl_EventuallyFree((ClientData)ivq, TCL_DYNAMIC); /* XXXXXXXX */ 9237#else 9238#if 0 /* use Tcl_Preserve/Release */ 9239 Tcl_Release(ivq); 9240#else 9241 ckfree((char*)ivq); 9242#endif 9243#endif 9244#endif 9245 9246 /* free allocated memory */ 9247 free_invoke_arguments(argc, av); 9248 9249 /* exception? */ 9250 if (rb_obj_is_kind_of(ret, rb_eException)) { 9251 DUMP1("raise exception"); 9252 /* rb_exc_raise(ret); */ 9253 rb_exc_raise(rb_exc_new3(rb_obj_class(ret), 9254 rb_funcall(ret, ID_to_s, 0, 0))); 9255 } 9256 9257 DUMP1("exit ip_invoke"); 9258 return ret; 9259} 9260 9261 9262/* get return code from Tcl_Eval() */ 9263static VALUE 9264ip_retval(self) 9265 VALUE self; 9266{ 9267 struct tcltkip *ptr; /* tcltkip data struct */ 9268 9269 /* get the data strcut */ 9270 ptr = get_ip(self); 9271 9272 /* ip is deleted? */ 9273 if (deleted_ip(ptr)) { 9274 return rb_tainted_str_new2(""); 9275 } 9276 9277 return (INT2FIX(ptr->return_value)); 9278} 9279 9280static VALUE 9281ip_invoke(argc, argv, obj) 9282 int argc; 9283 VALUE *argv; 9284 VALUE obj; 9285{ 9286 return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_TAIL); 9287} 9288 9289static VALUE 9290ip_invoke_immediate(argc, argv, obj) 9291 int argc; 9292 VALUE *argv; 9293 VALUE obj; 9294{ 9295 /* POTENTIALY INSECURE : can create infinite loop */ 9296 rb_secure(4); 9297 return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_HEAD); 9298} 9299 9300 9301/* access Tcl variables */ 9302static VALUE 9303ip_get_variable2_core(interp, argc, argv) 9304 VALUE interp; 9305 int argc; 9306 VALUE *argv; 9307{ 9308 struct tcltkip *ptr = get_ip(interp); 9309 int thr_crit_bup; 9310 volatile VALUE varname, index, flag; 9311 9312 varname = argv[0]; 9313 index = argv[1]; 9314 flag = argv[2]; 9315 9316 /* 9317 StringValue(varname); 9318 if (!NIL_P(index)) StringValue(index); 9319 */ 9320 9321#if TCL_MAJOR_VERSION >= 8 9322 { 9323 Tcl_Obj *ret; 9324 volatile VALUE strval; 9325 9326 thr_crit_bup = rb_thread_critical; 9327 rb_thread_critical = Qtrue; 9328 9329 /* ip is deleted? */ 9330 if (deleted_ip(ptr)) { 9331 rb_thread_critical = thr_crit_bup; 9332 return rb_tainted_str_new2(""); 9333 } else { 9334 /* Tcl_Preserve(ptr->ip); */ 9335 rbtk_preserve_ip(ptr); 9336 ret = Tcl_GetVar2Ex(ptr->ip, RSTRING_PTR(varname), 9337 NIL_P(index) ? NULL : RSTRING_PTR(index), 9338 FIX2INT(flag)); 9339 } 9340 9341 if (ret == (Tcl_Obj*)NULL) { 9342 volatile VALUE exc; 9343 /* exc = rb_exc_new2(rb_eRuntimeError, 9344 Tcl_GetStringResult(ptr->ip)); */ 9345 exc = create_ip_exc(interp, rb_eRuntimeError, "%s", 9346 Tcl_GetStringResult(ptr->ip)); 9347 /* Tcl_Release(ptr->ip); */ 9348 rbtk_release_ip(ptr); 9349 rb_thread_critical = thr_crit_bup; 9350 return exc; 9351 } 9352 9353 Tcl_IncrRefCount(ret); 9354 strval = get_str_from_obj(ret); 9355 RbTk_OBJ_UNTRUST(strval); 9356 Tcl_DecrRefCount(ret); 9357 9358 /* Tcl_Release(ptr->ip); */ 9359 rbtk_release_ip(ptr); 9360 rb_thread_critical = thr_crit_bup; 9361 return(strval); 9362 } 9363#else /* TCL_MAJOR_VERSION < 8 */ 9364 { 9365 char *ret; 9366 volatile VALUE strval; 9367 9368 /* ip is deleted? */ 9369 if (deleted_ip(ptr)) { 9370 return rb_tainted_str_new2(""); 9371 } else { 9372 /* Tcl_Preserve(ptr->ip); */ 9373 rbtk_preserve_ip(ptr); 9374 ret = Tcl_GetVar2(ptr->ip, RSTRING_PTR(varname), 9375 NIL_P(index) ? NULL : RSTRING_PTR(index), 9376 FIX2INT(flag)); 9377 } 9378 9379 if (ret == (char*)NULL) { 9380 volatile VALUE exc; 9381 exc = rb_exc_new2(rb_eRuntimeError, Tcl_GetStringResult(ptr->ip)); 9382 /* Tcl_Release(ptr->ip); */ 9383 rbtk_release_ip(ptr); 9384 rb_thread_critical = thr_crit_bup; 9385 return exc; 9386 } 9387 9388 strval = rb_tainted_str_new2(ret); 9389 /* Tcl_Release(ptr->ip); */ 9390 rbtk_release_ip(ptr); 9391 rb_thread_critical = thr_crit_bup; 9392 9393 return(strval); 9394 } 9395#endif 9396} 9397 9398static VALUE 9399ip_get_variable2(self, varname, index, flag) 9400 VALUE self; 9401 VALUE varname; 9402 VALUE index; 9403 VALUE flag; 9404{ 9405 VALUE argv[3]; 9406 VALUE retval; 9407 9408 StringValue(varname); 9409 if (!NIL_P(index)) StringValue(index); 9410 9411 argv[0] = varname; 9412 argv[1] = index; 9413 argv[2] = flag; 9414 9415 retval = tk_funcall(ip_get_variable2_core, 3, argv, self); 9416 9417 if (NIL_P(retval)) { 9418 return rb_tainted_str_new2(""); 9419 } else { 9420 return retval; 9421 } 9422} 9423 9424static VALUE 9425ip_get_variable(self, varname, flag) 9426 VALUE self; 9427 VALUE varname; 9428 VALUE flag; 9429{ 9430 return ip_get_variable2(self, varname, Qnil, flag); 9431} 9432 9433static VALUE 9434ip_set_variable2_core(interp, argc, argv) 9435 VALUE interp; 9436 int argc; 9437 VALUE *argv; 9438{ 9439 struct tcltkip *ptr = get_ip(interp); 9440 int thr_crit_bup; 9441 volatile VALUE varname, index, value, flag; 9442 9443 varname = argv[0]; 9444 index = argv[1]; 9445 value = argv[2]; 9446 flag = argv[3]; 9447 9448 /* 9449 StringValue(varname); 9450 if (!NIL_P(index)) StringValue(index); 9451 StringValue(value); 9452 */ 9453 9454#if TCL_MAJOR_VERSION >= 8 9455 { 9456 Tcl_Obj *valobj, *ret; 9457 volatile VALUE strval; 9458 9459 thr_crit_bup = rb_thread_critical; 9460 rb_thread_critical = Qtrue; 9461 9462 valobj = get_obj_from_str(value); 9463 Tcl_IncrRefCount(valobj); 9464 9465 /* ip is deleted? */ 9466 if (deleted_ip(ptr)) { 9467 Tcl_DecrRefCount(valobj); 9468 rb_thread_critical = thr_crit_bup; 9469 return rb_tainted_str_new2(""); 9470 } else { 9471 /* Tcl_Preserve(ptr->ip); */ 9472 rbtk_preserve_ip(ptr); 9473 ret = Tcl_SetVar2Ex(ptr->ip, RSTRING_PTR(varname), 9474 NIL_P(index) ? NULL : RSTRING_PTR(index), 9475 valobj, FIX2INT(flag)); 9476 } 9477 9478 Tcl_DecrRefCount(valobj); 9479 9480 if (ret == (Tcl_Obj*)NULL) { 9481 volatile VALUE exc; 9482 /* exc = rb_exc_new2(rb_eRuntimeError, 9483 Tcl_GetStringResult(ptr->ip)); */ 9484 exc = create_ip_exc(interp, rb_eRuntimeError, "%s", 9485 Tcl_GetStringResult(ptr->ip)); 9486 /* Tcl_Release(ptr->ip); */ 9487 rbtk_release_ip(ptr); 9488 rb_thread_critical = thr_crit_bup; 9489 return exc; 9490 } 9491 9492 Tcl_IncrRefCount(ret); 9493 strval = get_str_from_obj(ret); 9494 RbTk_OBJ_UNTRUST(strval); 9495 Tcl_DecrRefCount(ret); 9496 9497 /* Tcl_Release(ptr->ip); */ 9498 rbtk_release_ip(ptr); 9499 rb_thread_critical = thr_crit_bup; 9500 9501 return(strval); 9502 } 9503#else /* TCL_MAJOR_VERSION < 8 */ 9504 { 9505 CONST char *ret; 9506 volatile VALUE strval; 9507 9508 /* ip is deleted? */ 9509 if (deleted_ip(ptr)) { 9510 return rb_tainted_str_new2(""); 9511 } else { 9512 /* Tcl_Preserve(ptr->ip); */ 9513 rbtk_preserve_ip(ptr); 9514 ret = Tcl_SetVar2(ptr->ip, RSTRING_PTR(varname), 9515 NIL_P(index) ? NULL : RSTRING_PTR(index), 9516 RSTRING_PTR(value), FIX2INT(flag)); 9517 } 9518 9519 if (ret == (char*)NULL) { 9520 return rb_exc_new2(rb_eRuntimeError, ptr->ip->result); 9521 } 9522 9523 strval = rb_tainted_str_new2(ret); 9524 9525 /* Tcl_Release(ptr->ip); */ 9526 rbtk_release_ip(ptr); 9527 rb_thread_critical = thr_crit_bup; 9528 9529 return(strval); 9530 } 9531#endif 9532} 9533 9534static VALUE 9535ip_set_variable2(self, varname, index, value, flag) 9536 VALUE self; 9537 VALUE varname; 9538 VALUE index; 9539 VALUE value; 9540 VALUE flag; 9541{ 9542 VALUE argv[4]; 9543 VALUE retval; 9544 9545 StringValue(varname); 9546 if (!NIL_P(index)) StringValue(index); 9547 StringValue(value); 9548 9549 argv[0] = varname; 9550 argv[1] = index; 9551 argv[2] = value; 9552 argv[3] = flag; 9553 9554 retval = tk_funcall(ip_set_variable2_core, 4, argv, self); 9555 9556 if (NIL_P(retval)) { 9557 return rb_tainted_str_new2(""); 9558 } else { 9559 return retval; 9560 } 9561} 9562 9563static VALUE 9564ip_set_variable(self, varname, value, flag) 9565 VALUE self; 9566 VALUE varname; 9567 VALUE value; 9568 VALUE flag; 9569{ 9570 return ip_set_variable2(self, varname, Qnil, value, flag); 9571} 9572 9573static VALUE 9574ip_unset_variable2_core(interp, argc, argv) 9575 VALUE interp; 9576 int argc; 9577 VALUE *argv; 9578{ 9579 struct tcltkip *ptr = get_ip(interp); 9580 volatile VALUE varname, index, flag; 9581 9582 varname = argv[0]; 9583 index = argv[1]; 9584 flag = argv[2]; 9585 9586 /* 9587 StringValue(varname); 9588 if (!NIL_P(index)) StringValue(index); 9589 */ 9590 9591 /* ip is deleted? */ 9592 if (deleted_ip(ptr)) { 9593 return Qtrue; 9594 } 9595 9596 ptr->return_value = Tcl_UnsetVar2(ptr->ip, RSTRING_PTR(varname), 9597 NIL_P(index) ? NULL : RSTRING_PTR(index), 9598 FIX2INT(flag)); 9599 9600 if (ptr->return_value == TCL_ERROR) { 9601 if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) { 9602 /* return rb_exc_new2(rb_eRuntimeError, 9603 Tcl_GetStringResult(ptr->ip)); */ 9604 return create_ip_exc(interp, rb_eRuntimeError, "%s", 9605 Tcl_GetStringResult(ptr->ip)); 9606 } 9607 return Qfalse; 9608 } 9609 return Qtrue; 9610} 9611 9612static VALUE 9613ip_unset_variable2(self, varname, index, flag) 9614 VALUE self; 9615 VALUE varname; 9616 VALUE index; 9617 VALUE flag; 9618{ 9619 VALUE argv[3]; 9620 VALUE retval; 9621 9622 StringValue(varname); 9623 if (!NIL_P(index)) StringValue(index); 9624 9625 argv[0] = varname; 9626 argv[1] = index; 9627 argv[2] = flag; 9628 9629 retval = tk_funcall(ip_unset_variable2_core, 3, argv, self); 9630 9631 if (NIL_P(retval)) { 9632 return rb_tainted_str_new2(""); 9633 } else { 9634 return retval; 9635 } 9636} 9637 9638static VALUE 9639ip_unset_variable(self, varname, flag) 9640 VALUE self; 9641 VALUE varname; 9642 VALUE flag; 9643{ 9644 return ip_unset_variable2(self, varname, Qnil, flag); 9645} 9646 9647static VALUE 9648ip_get_global_var(self, varname) 9649 VALUE self; 9650 VALUE varname; 9651{ 9652 return ip_get_variable(self, varname, 9653 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); 9654} 9655 9656static VALUE 9657ip_get_global_var2(self, varname, index) 9658 VALUE self; 9659 VALUE varname; 9660 VALUE index; 9661{ 9662 return ip_get_variable2(self, varname, index, 9663 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); 9664} 9665 9666static VALUE 9667ip_set_global_var(self, varname, value) 9668 VALUE self; 9669 VALUE varname; 9670 VALUE value; 9671{ 9672 return ip_set_variable(self, varname, value, 9673 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); 9674} 9675 9676static VALUE 9677ip_set_global_var2(self, varname, index, value) 9678 VALUE self; 9679 VALUE varname; 9680 VALUE index; 9681 VALUE value; 9682{ 9683 return ip_set_variable2(self, varname, index, value, 9684 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); 9685} 9686 9687static VALUE 9688ip_unset_global_var(self, varname) 9689 VALUE self; 9690 VALUE varname; 9691{ 9692 return ip_unset_variable(self, varname, 9693 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); 9694} 9695 9696static VALUE 9697ip_unset_global_var2(self, varname, index) 9698 VALUE self; 9699 VALUE varname; 9700 VALUE index; 9701{ 9702 return ip_unset_variable2(self, varname, index, 9703 INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); 9704} 9705 9706 9707/* treat Tcl_List */ 9708static VALUE 9709lib_split_tklist_core(ip_obj, list_str) 9710 VALUE ip_obj; 9711 VALUE list_str; 9712{ 9713 Tcl_Interp *interp; 9714 volatile VALUE ary, elem; 9715 int idx; 9716 int taint_flag = OBJ_TAINTED(list_str); 9717#ifdef HAVE_RUBY_ENCODING_H 9718 int list_enc_idx; 9719 volatile VALUE list_ivar_enc; 9720#endif 9721 int result; 9722 VALUE old_gc; 9723 9724 tcl_stubs_check(); 9725 9726 if (NIL_P(ip_obj)) { 9727 interp = (Tcl_Interp *)NULL; 9728 } else if (get_ip(ip_obj) == (struct tcltkip *)NULL) { 9729 interp = (Tcl_Interp *)NULL; 9730 } else { 9731 interp = get_ip(ip_obj)->ip; 9732 } 9733 9734 StringValue(list_str); 9735#ifdef HAVE_RUBY_ENCODING_H 9736 list_enc_idx = rb_enc_get_index(list_str); 9737 list_ivar_enc = rb_ivar_get(list_str, ID_at_enc); 9738#endif 9739 9740 { 9741#if TCL_MAJOR_VERSION >= 8 9742 /* object style interface */ 9743 Tcl_Obj *listobj; 9744 int objc; 9745 Tcl_Obj **objv; 9746 int thr_crit_bup; 9747 9748 listobj = get_obj_from_str(list_str); 9749 9750 Tcl_IncrRefCount(listobj); 9751 9752 result = Tcl_ListObjGetElements(interp, listobj, &objc, &objv); 9753 9754 if (result == TCL_ERROR) { 9755 Tcl_DecrRefCount(listobj); 9756 if (interp == (Tcl_Interp*)NULL) { 9757 rb_raise(rb_eRuntimeError, "can't get elements from list"); 9758 } else { 9759 rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(interp)); 9760 } 9761 } 9762 9763 for(idx = 0; idx < objc; idx++) { 9764 Tcl_IncrRefCount(objv[idx]); 9765 } 9766 9767 thr_crit_bup = rb_thread_critical; 9768 rb_thread_critical = Qtrue; 9769 9770 ary = rb_ary_new2(objc); 9771 if (taint_flag) RbTk_OBJ_UNTRUST(ary); 9772 9773 old_gc = rb_gc_disable(); 9774 9775 for(idx = 0; idx < objc; idx++) { 9776 elem = get_str_from_obj(objv[idx]); 9777 if (taint_flag) RbTk_OBJ_UNTRUST(elem); 9778 9779#ifdef HAVE_RUBY_ENCODING_H 9780 if (rb_enc_get_index(elem) == ENCODING_INDEX_BINARY) { 9781 rb_enc_associate_index(elem, ENCODING_INDEX_BINARY); 9782 rb_ivar_set(elem, ID_at_enc, ENCODING_NAME_BINARY); 9783 } else { 9784 rb_enc_associate_index(elem, list_enc_idx); 9785 rb_ivar_set(elem, ID_at_enc, list_ivar_enc); 9786 } 9787#endif 9788 /* RARRAY(ary)->ptr[idx] = elem; */ 9789 rb_ary_push(ary, elem); 9790 } 9791 9792 /* RARRAY(ary)->len = objc; */ 9793 9794 if (old_gc == Qfalse) rb_gc_enable(); 9795 9796 rb_thread_critical = thr_crit_bup; 9797 9798 for(idx = 0; idx < objc; idx++) { 9799 Tcl_DecrRefCount(objv[idx]); 9800 } 9801 9802 Tcl_DecrRefCount(listobj); 9803 9804#else /* TCL_MAJOR_VERSION < 8 */ 9805 /* string style interface */ 9806 int argc; 9807 char **argv; 9808 9809 if (Tcl_SplitList(interp, RSTRING_PTR(list_str), 9810 &argc, &argv) == TCL_ERROR) { 9811 if (interp == (Tcl_Interp*)NULL) { 9812 rb_raise(rb_eRuntimeError, "can't get elements from list"); 9813 } else { 9814 rb_raise(rb_eRuntimeError, "%s", interp->result); 9815 } 9816 } 9817 9818 ary = rb_ary_new2(argc); 9819 if (taint_flag) RbTk_OBJ_UNTRUST(ary); 9820 9821 old_gc = rb_gc_disable(); 9822 9823 for(idx = 0; idx < argc; idx++) { 9824 if (taint_flag) { 9825 elem = rb_tainted_str_new2(argv[idx]); 9826 } else { 9827 elem = rb_str_new2(argv[idx]); 9828 } 9829 /* rb_ivar_set(elem, ID_at_enc, rb_str_new2("binary")); */ 9830 /* RARRAY(ary)->ptr[idx] = elem; */ 9831 rb_ary_push(ary, elem) 9832 } 9833 /* RARRAY(ary)->len = argc; */ 9834 9835 if (old_gc == Qfalse) rb_gc_enable(); 9836#endif 9837 } 9838 9839 return ary; 9840} 9841 9842static VALUE 9843lib_split_tklist(self, list_str) 9844 VALUE self; 9845 VALUE list_str; 9846{ 9847 return lib_split_tklist_core(Qnil, list_str); 9848} 9849 9850 9851static VALUE 9852ip_split_tklist(self, list_str) 9853 VALUE self; 9854 VALUE list_str; 9855{ 9856 return lib_split_tklist_core(self, list_str); 9857} 9858 9859static VALUE 9860lib_merge_tklist(argc, argv, obj) 9861 int argc; 9862 VALUE *argv; 9863 VALUE obj; 9864{ 9865 int num, len; 9866 int *flagPtr; 9867 char *dst, *result; 9868 volatile VALUE str; 9869 int taint_flag = 0; 9870 int thr_crit_bup; 9871 VALUE old_gc; 9872 9873 if (argc == 0) return rb_str_new2(""); 9874 9875 tcl_stubs_check(); 9876 9877 thr_crit_bup = rb_thread_critical; 9878 rb_thread_critical = Qtrue; 9879 old_gc = rb_gc_disable(); 9880 9881 /* based on Tcl/Tk's Tcl_Merge() */ 9882 /* flagPtr = ALLOC_N(int, argc); */ 9883 flagPtr = RbTk_ALLOC_N(int, argc); 9884#if 0 /* use Tcl_Preserve/Release */ 9885 Tcl_Preserve((ClientData)flagPtr); /* XXXXXXXXXX */ 9886#endif 9887 9888 /* pass 1 */ 9889 len = 1; 9890 for(num = 0; num < argc; num++) { 9891 if (OBJ_TAINTED(argv[num])) taint_flag = 1; 9892 dst = StringValuePtr(argv[num]); 9893#if TCL_MAJOR_VERSION >= 8 9894 len += Tcl_ScanCountedElement(dst, RSTRING_LENINT(argv[num]), 9895 &flagPtr[num]) + 1; 9896#else /* TCL_MAJOR_VERSION < 8 */ 9897 len += Tcl_ScanElement(dst, &flagPtr[num]) + 1; 9898#endif 9899 } 9900 9901 /* pass 2 */ 9902 /* result = (char *)Tcl_Alloc(len); */ 9903 result = (char *)ckalloc(len); 9904#if 0 /* use Tcl_Preserve/Release */ 9905 Tcl_Preserve((ClientData)result); 9906#endif 9907 dst = result; 9908 for(num = 0; num < argc; num++) { 9909#if TCL_MAJOR_VERSION >= 8 9910 len = Tcl_ConvertCountedElement(RSTRING_PTR(argv[num]), 9911 RSTRING_LENINT(argv[num]), 9912 dst, flagPtr[num]); 9913#else /* TCL_MAJOR_VERSION < 8 */ 9914 len = Tcl_ConvertElement(RSTRING_PTR(argv[num]), dst, flagPtr[num]); 9915#endif 9916 dst += len; 9917 *dst = ' '; 9918 dst++; 9919 } 9920 if (dst == result) { 9921 *dst = 0; 9922 } else { 9923 dst[-1] = 0; 9924 } 9925 9926#if 0 /* use Tcl_EventuallyFree */ 9927 Tcl_EventuallyFree((ClientData)flagPtr, TCL_DYNAMIC); /* XXXXXXXX */ 9928#else 9929#if 0 /* use Tcl_Preserve/Release */ 9930 Tcl_Release((ClientData)flagPtr); 9931#else 9932 /* free(flagPtr); */ 9933 ckfree((char*)flagPtr); 9934#endif 9935#endif 9936 9937 /* create object */ 9938 str = rb_str_new(result, dst - result - 1); 9939 if (taint_flag) RbTk_OBJ_UNTRUST(str); 9940#if 0 /* use Tcl_EventuallyFree */ 9941 Tcl_EventuallyFree((ClientData)result, TCL_DYNAMIC); /* XXXXXXXX */ 9942#else 9943#if 0 /* use Tcl_Preserve/Release */ 9944 Tcl_Release((ClientData)result); /* XXXXXXXXXXX */ 9945#else 9946 /* Tcl_Free(result); */ 9947 ckfree(result); 9948#endif 9949#endif 9950 9951 if (old_gc == Qfalse) rb_gc_enable(); 9952 rb_thread_critical = thr_crit_bup; 9953 9954 return str; 9955} 9956 9957static VALUE 9958lib_conv_listelement(self, src) 9959 VALUE self; 9960 VALUE src; 9961{ 9962 int len, scan_flag; 9963 volatile VALUE dst; 9964 int taint_flag = OBJ_TAINTED(src); 9965 int thr_crit_bup; 9966 9967 tcl_stubs_check(); 9968 9969 thr_crit_bup = rb_thread_critical; 9970 rb_thread_critical = Qtrue; 9971 9972 StringValue(src); 9973 9974#if TCL_MAJOR_VERSION >= 8 9975 len = Tcl_ScanCountedElement(RSTRING_PTR(src), RSTRING_LENINT(src), 9976 &scan_flag); 9977 dst = rb_str_new(0, len + 1); 9978 len = Tcl_ConvertCountedElement(RSTRING_PTR(src), RSTRING_LENINT(src), 9979 RSTRING_PTR(dst), scan_flag); 9980#else /* TCL_MAJOR_VERSION < 8 */ 9981 len = Tcl_ScanElement(RSTRING_PTR(src), &scan_flag); 9982 dst = rb_str_new(0, len + 1); 9983 len = Tcl_ConvertElement(RSTRING_PTR(src), RSTRING_PTR(dst), scan_flag); 9984#endif 9985 9986 rb_str_resize(dst, len); 9987 if (taint_flag) RbTk_OBJ_UNTRUST(dst); 9988 9989 rb_thread_critical = thr_crit_bup; 9990 9991 return dst; 9992} 9993 9994static VALUE 9995lib_getversion(self) 9996 VALUE self; 9997{ 9998 set_tcltk_version(); 9999 10000 return rb_ary_new3(4, INT2NUM(tcltk_version.major), 10001 INT2NUM(tcltk_version.minor), 10002 INT2NUM(tcltk_version.type), 10003 INT2NUM(tcltk_version.patchlevel)); 10004} 10005 10006static VALUE 10007lib_get_reltype_name(self) 10008 VALUE self; 10009{ 10010 set_tcltk_version(); 10011 10012 switch(tcltk_version.type) { 10013 case TCL_ALPHA_RELEASE: 10014 return rb_str_new2("alpha"); 10015 case TCL_BETA_RELEASE: 10016 return rb_str_new2("beta"); 10017 case TCL_FINAL_RELEASE: 10018 return rb_str_new2("final"); 10019 default: 10020 rb_raise(rb_eRuntimeError, "tcltklib has invalid release type number"); 10021 } 10022 10023 UNREACHABLE; 10024} 10025 10026 10027static VALUE 10028tcltklib_compile_info() 10029{ 10030 volatile VALUE ret; 10031 size_t size; 10032 static CONST char form[] 10033 = "tcltklib %s :: Ruby%s (%s) %s pthread :: Tcl%s(%s)/Tk%s(%s) %s"; 10034 char *info; 10035 10036 size = strlen(form) 10037 + strlen(TCLTKLIB_RELEASE_DATE) 10038 + strlen(RUBY_VERSION) 10039 + strlen(RUBY_RELEASE_DATE) 10040 + strlen("without") 10041 + strlen(TCL_PATCH_LEVEL) 10042 + strlen("without stub") 10043 + strlen(TK_PATCH_LEVEL) 10044 + strlen("without stub") 10045 + strlen("unknown tcl_threads"); 10046 10047 info = ALLOC_N(char, size); 10048 /* info = ckalloc(sizeof(char) * size); */ /* SEGV */ 10049 10050 sprintf(info, form, 10051 TCLTKLIB_RELEASE_DATE, 10052 RUBY_VERSION, RUBY_RELEASE_DATE, 10053#ifdef HAVE_NATIVETHREAD 10054 "with", 10055#else 10056 "without", 10057#endif 10058 TCL_PATCH_LEVEL, 10059#ifdef USE_TCL_STUBS 10060 "with stub", 10061#else 10062 "without stub", 10063#endif 10064 TK_PATCH_LEVEL, 10065#ifdef USE_TK_STUBS 10066 "with stub", 10067#else 10068 "without stub", 10069#endif 10070#ifdef WITH_TCL_ENABLE_THREAD 10071# if WITH_TCL_ENABLE_THREAD 10072 "with tcl_threads" 10073# else 10074 "without tcl_threads" 10075# endif 10076#else 10077 "unknown tcl_threads" 10078#endif 10079 ); 10080 10081 ret = rb_obj_freeze(rb_str_new2(info)); 10082 10083 xfree(info); 10084 /* ckfree(info); */ 10085 10086 return ret; 10087} 10088 10089 10090/*###############################################*/ 10091 10092static VALUE 10093create_dummy_encoding_for_tk_core(interp, name, error_mode) 10094 VALUE interp; 10095 VALUE name; 10096 VALUE error_mode; 10097{ 10098 get_ip(interp); 10099 10100 rb_secure(4); 10101 10102 StringValue(name); 10103 10104#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1) 10105 if (Tcl_GetEncoding((Tcl_Interp*)NULL, RSTRING_PTR(name)) == (Tcl_Encoding)NULL) { 10106 if (RTEST(error_mode)) { 10107 rb_raise(rb_eArgError, "invalid Tk encoding name '%s'", 10108 RSTRING_PTR(name)); 10109 } else { 10110 return Qnil; 10111 } 10112 } 10113#endif 10114 10115#ifdef HAVE_RUBY_ENCODING_H 10116 if (RTEST(rb_define_dummy_encoding(RSTRING_PTR(name)))) { 10117 int idx = rb_enc_find_index(StringValueCStr(name)); 10118 return rb_enc_from_encoding(rb_enc_from_index(idx)); 10119 } else { 10120 if (RTEST(error_mode)) { 10121 rb_raise(rb_eRuntimeError, "fail to create dummy encoding for '%s'", 10122 RSTRING_PTR(name)); 10123 } else { 10124 return Qnil; 10125 } 10126 } 10127 10128 UNREACHABLE; 10129#else 10130 return name; 10131#endif 10132} 10133static VALUE 10134create_dummy_encoding_for_tk(interp, name) 10135 VALUE interp; 10136 VALUE name; 10137{ 10138 return create_dummy_encoding_for_tk_core(interp, name, Qtrue); 10139} 10140 10141 10142#ifdef HAVE_RUBY_ENCODING_H 10143static int 10144update_encoding_table(table, interp, error_mode) 10145 VALUE table; 10146 VALUE interp; 10147 VALUE error_mode; 10148{ 10149 struct tcltkip *ptr; 10150 int retry = 0; 10151 int i, idx, objc; 10152 Tcl_Obj **objv; 10153 Tcl_Obj *enc_list; 10154 volatile VALUE encname = Qnil; 10155 volatile VALUE encobj = Qnil; 10156 10157 /* interpreter check */ 10158 if (NIL_P(interp)) return 0; 10159 ptr = get_ip(interp); 10160 if (ptr == (struct tcltkip *) NULL) return 0; 10161 if (deleted_ip(ptr)) return 0; 10162 10163 /* get Tcl's encoding list */ 10164 Tcl_GetEncodingNames(ptr->ip); 10165 enc_list = Tcl_GetObjResult(ptr->ip); 10166 Tcl_IncrRefCount(enc_list); 10167 10168 if (Tcl_ListObjGetElements(ptr->ip, enc_list, 10169 &objc, &objv) != TCL_OK) { 10170 Tcl_DecrRefCount(enc_list); 10171 /* rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names");*/ 10172 return 0; 10173 } 10174 10175 /* check each encoding name */ 10176 for(i = 0; i < objc; i++) { 10177 encname = rb_str_new2(Tcl_GetString(objv[i])); 10178 if (NIL_P(rb_hash_lookup(table, encname))) { 10179 /* new Tk encoding -> add to table */ 10180 idx = rb_enc_find_index(StringValueCStr(encname)); 10181 if (idx < 0) { 10182 encobj = create_dummy_encoding_for_tk_core(interp,encname,error_mode); 10183 } else { 10184 encobj = rb_enc_from_encoding(rb_enc_from_index(idx)); 10185 } 10186 encname = rb_obj_freeze(encname); 10187 rb_hash_aset(table, encname, encobj); 10188 if (!NIL_P(encobj) && NIL_P(rb_hash_lookup(table, encobj))) { 10189 rb_hash_aset(table, encobj, encname); 10190 } 10191 retry = 1; 10192 } 10193 } 10194 10195 Tcl_DecrRefCount(enc_list); 10196 10197 return retry; 10198} 10199 10200static VALUE 10201encoding_table_get_name_core(table, enc_arg, error_mode) 10202 VALUE table; 10203 VALUE enc_arg; 10204 VALUE error_mode; 10205{ 10206 volatile VALUE enc = enc_arg; 10207 volatile VALUE name = Qnil; 10208 volatile VALUE tmp = Qnil; 10209 volatile VALUE interp = rb_ivar_get(table, ID_at_interp); 10210 struct tcltkip *ptr = (struct tcltkip *) NULL; 10211 int idx; 10212 10213 /* deleted interp ? */ 10214 if (!NIL_P(interp)) { 10215 ptr = get_ip(interp); 10216 if (deleted_ip(ptr)) { 10217 ptr = (struct tcltkip *) NULL; 10218 } 10219 } 10220 10221 /* encoding argument check */ 10222 /* 1st: default encoding setting of interp */ 10223 if (ptr && NIL_P(enc)) { 10224 if (rb_respond_to(interp, ID_encoding_name)) { 10225 enc = rb_funcall(interp, ID_encoding_name, 0, 0); 10226 } 10227 } 10228 /* 2nd: Encoding.default_internal */ 10229 if (NIL_P(enc)) { 10230 enc = rb_enc_default_internal(); 10231 } 10232 /* 3rd: encoding system of Tcl/Tk */ 10233 if (NIL_P(enc)) { 10234 enc = rb_str_new2(Tcl_GetEncodingName((Tcl_Encoding)NULL)); 10235 } 10236 /* 4th: Encoding.default_external */ 10237 if (NIL_P(enc)) { 10238 enc = rb_enc_default_external(); 10239 } 10240 /* 5th: Encoding.locale_charmap */ 10241 if (NIL_P(enc)) { 10242 enc = rb_locale_charmap(rb_cEncoding); 10243 } 10244 10245 if (RTEST(rb_obj_is_kind_of(enc, cRubyEncoding))) { 10246 /* Ruby's Encoding object */ 10247 name = rb_hash_lookup(table, enc); 10248 if (!NIL_P(name)) { 10249 /* find */ 10250 return name; 10251 } 10252 10253 /* is it new ? */ 10254 /* update check of Tk encoding names */ 10255 if (update_encoding_table(table, interp, error_mode)) { 10256 /* add new relations to the table */ 10257 /* RETRY: registered Ruby encoding? */ 10258 name = rb_hash_lookup(table, enc); 10259 if (!NIL_P(name)) { 10260 /* find */ 10261 return name; 10262 } 10263 } 10264 /* fail to find */ 10265 10266 } else { 10267 /* String or Symbol? */ 10268 name = rb_funcall(enc, ID_to_s, 0, 0); 10269 10270 if (!NIL_P(rb_hash_lookup(table, name))) { 10271 /* find */ 10272 return name; 10273 } 10274 10275 /* is it new ? */ 10276 idx = rb_enc_find_index(StringValueCStr(name)); 10277 if (idx >= 0) { 10278 enc = rb_enc_from_encoding(rb_enc_from_index(idx)); 10279 10280 /* registered Ruby encoding? */ 10281 tmp = rb_hash_lookup(table, enc); 10282 if (!NIL_P(tmp)) { 10283 /* find */ 10284 return tmp; 10285 } 10286 10287 /* update check of Tk encoding names */ 10288 if (update_encoding_table(table, interp, error_mode)) { 10289 /* add new relations to the table */ 10290 /* RETRY: registered Ruby encoding? */ 10291 tmp = rb_hash_lookup(table, enc); 10292 if (!NIL_P(tmp)) { 10293 /* find */ 10294 return tmp; 10295 } 10296 } 10297 } 10298 /* fail to find */ 10299 } 10300 10301 if (RTEST(error_mode)) { 10302 enc = rb_funcall(enc_arg, ID_to_s, 0, 0); 10303 rb_raise(rb_eArgError, "unsupported Tk encoding '%s'", RSTRING_PTR(enc)); 10304 } 10305 return Qnil; 10306} 10307static VALUE 10308encoding_table_get_obj_core(table, enc, error_mode) 10309 VALUE table; 10310 VALUE enc; 10311 VALUE error_mode; 10312{ 10313 volatile VALUE obj = Qnil; 10314 10315 obj = rb_hash_lookup(table, 10316 encoding_table_get_name_core(table, enc, error_mode)); 10317 if (RTEST(rb_obj_is_kind_of(obj, cRubyEncoding))) { 10318 return obj; 10319 } else { 10320 return Qnil; 10321 } 10322} 10323 10324#else /* ! HAVE_RUBY_ENCODING_H */ 10325#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1) 10326static int 10327update_encoding_table(table, interp, error_mode) 10328 VALUE table; 10329 VALUE interp; 10330 VALUE error_mode; 10331{ 10332 struct tcltkip *ptr; 10333 int retry = 0; 10334 int i, objc; 10335 Tcl_Obj **objv; 10336 Tcl_Obj *enc_list; 10337 volatile VALUE encname = Qnil; 10338 10339 /* interpreter check */ 10340 if (NIL_P(interp)) return 0; 10341 ptr = get_ip(interp); 10342 if (ptr == (struct tcltkip *) NULL) return 0; 10343 if (deleted_ip(ptr)) return 0; 10344 10345 /* get Tcl's encoding list */ 10346 Tcl_GetEncodingNames(ptr->ip); 10347 enc_list = Tcl_GetObjResult(ptr->ip); 10348 Tcl_IncrRefCount(enc_list); 10349 10350 if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) { 10351 Tcl_DecrRefCount(enc_list); 10352 /* rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names"); */ 10353 return 0; 10354 } 10355 10356 /* get encoding name and set it to table */ 10357 for(i = 0; i < objc; i++) { 10358 encname = rb_str_new2(Tcl_GetString(objv[i])); 10359 if (NIL_P(rb_hash_lookup(table, encname))) { 10360 /* new Tk encoding -> add to table */ 10361 encname = rb_obj_freeze(encname); 10362 rb_hash_aset(table, encname, encname); 10363 retry = 1; 10364 } 10365 } 10366 10367 Tcl_DecrRefCount(enc_list); 10368 10369 return retry; 10370} 10371 10372static VALUE 10373encoding_table_get_name_core(table, enc, error_mode) 10374 VALUE table; 10375 VALUE enc; 10376 VALUE error_mode; 10377{ 10378 volatile VALUE name = Qnil; 10379 10380 enc = rb_funcall(enc, ID_to_s, 0, 0); 10381 name = rb_hash_lookup(table, enc); 10382 10383 if (!NIL_P(name)) { 10384 /* find */ 10385 return name; 10386 } 10387 10388 /* update check */ 10389 if (update_encoding_table(table, rb_ivar_get(table, ID_at_interp), 10390 error_mode)) { 10391 /* add new relations to the table */ 10392 /* RETRY: registered Ruby encoding? */ 10393 name = rb_hash_lookup(table, enc); 10394 if (!NIL_P(name)) { 10395 /* find */ 10396 return name; 10397 } 10398 } 10399 10400 if (RTEST(error_mode)) { 10401 rb_raise(rb_eArgError, "unsupported Tk encoding '%s'", RSTRING_PTR(enc)); 10402 } 10403 return Qnil; 10404} 10405static VALUE 10406encoding_table_get_obj_core(table, enc, error_mode) 10407 VALUE table; 10408 VALUE enc; 10409 VALUE error_mode; 10410{ 10411 return encoding_table_get_name_core(table, enc, error_mode); 10412} 10413 10414#else /* Tcl/Tk 7.x or 8.0 */ 10415static VALUE 10416encoding_table_get_name_core(table, enc, error_mode) 10417 VALUE table; 10418 VALUE enc; 10419 VALUE error_mode; 10420{ 10421 return Qnil; 10422} 10423static VALUE 10424encoding_table_get_obj_core(table, enc, error_mode) 10425 VALUE table; 10426 VALUE enc; 10427 VALUE error_mode; 10428{ 10429 return Qnil; 10430} 10431#endif /* end of dependency for the version of Tcl/Tk */ 10432#endif 10433 10434static VALUE 10435encoding_table_get_name(table, enc) 10436 VALUE table; 10437 VALUE enc; 10438{ 10439 return encoding_table_get_name_core(table, enc, Qtrue); 10440} 10441static VALUE 10442encoding_table_get_obj(table, enc) 10443 VALUE table; 10444 VALUE enc; 10445{ 10446 return encoding_table_get_obj_core(table, enc, Qtrue); 10447} 10448 10449#ifdef HAVE_RUBY_ENCODING_H 10450static VALUE 10451create_encoding_table_core(arg, interp) 10452 VALUE arg; 10453 VALUE interp; 10454{ 10455 struct tcltkip *ptr = get_ip(interp); 10456 volatile VALUE table = rb_hash_new(); 10457 volatile VALUE encname = Qnil; 10458 volatile VALUE encobj = Qnil; 10459 int i, idx, objc; 10460 Tcl_Obj **objv; 10461 Tcl_Obj *enc_list; 10462 10463#ifdef HAVE_RB_SET_SAFE_LEVEL_FORCE 10464 rb_set_safe_level_force(0); 10465#else 10466 rb_set_safe_level(0); 10467#endif 10468 10469 /* set 'binary' encoding */ 10470 encobj = rb_enc_from_encoding(rb_enc_from_index(ENCODING_INDEX_BINARY)); 10471 rb_hash_aset(table, ENCODING_NAME_BINARY, encobj); 10472 rb_hash_aset(table, encobj, ENCODING_NAME_BINARY); 10473 10474 10475 /* Tcl stub check */ 10476 tcl_stubs_check(); 10477 10478 /* get Tcl's encoding list */ 10479 Tcl_GetEncodingNames(ptr->ip); 10480 enc_list = Tcl_GetObjResult(ptr->ip); 10481 Tcl_IncrRefCount(enc_list); 10482 10483 if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) { 10484 Tcl_DecrRefCount(enc_list); 10485 rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names"); 10486 } 10487 10488 /* get encoding name and set it to table */ 10489 for(i = 0; i < objc; i++) { 10490 int name2obj, obj2name; 10491 10492 name2obj = 1; obj2name = 1; 10493 encname = rb_obj_freeze(rb_str_new2(Tcl_GetString(objv[i]))); 10494 idx = rb_enc_find_index(StringValueCStr(encname)); 10495 if (idx < 0) { 10496 /* fail to find ruby encoding -> check known encoding */ 10497 if (strcmp(RSTRING_PTR(encname), "identity") == 0) { 10498 name2obj = 1; obj2name = 0; 10499 idx = ENCODING_INDEX_BINARY; 10500 10501 } else if (strcmp(RSTRING_PTR(encname), "shiftjis") == 0) { 10502 name2obj = 1; obj2name = 0; 10503 idx = rb_enc_find_index("Shift_JIS"); 10504 10505 } else if (strcmp(RSTRING_PTR(encname), "unicode") == 0) { 10506 name2obj = 1; obj2name = 0; 10507 idx = ENCODING_INDEX_UTF8; 10508 10509 } else if (strcmp(RSTRING_PTR(encname), "symbol") == 0) { 10510 name2obj = 1; obj2name = 0; 10511 idx = rb_enc_find_index("ASCII-8BIT"); 10512 10513 } else { 10514 /* regist dummy encoding */ 10515 name2obj = 1; obj2name = 1; 10516 } 10517 } 10518 10519 if (idx < 0) { 10520 /* unknown encoding -> create dummy */ 10521 encobj = create_dummy_encoding_for_tk(interp, encname); 10522 } else { 10523 encobj = rb_enc_from_encoding(rb_enc_from_index(idx)); 10524 } 10525 10526 if (name2obj) { 10527 DUMP2("create_encoding_table: name2obj: %s", RSTRING_PTR(encname)); 10528 rb_hash_aset(table, encname, encobj); 10529 } 10530 if (obj2name) { 10531 DUMP2("create_encoding_table: obj2name: %s", RSTRING_PTR(encname)); 10532 rb_hash_aset(table, encobj, encname); 10533 } 10534 } 10535 10536 Tcl_DecrRefCount(enc_list); 10537 10538 rb_ivar_set(table, ID_at_interp, interp); 10539 rb_ivar_set(interp, ID_encoding_table, table); 10540 10541 return table; 10542} 10543 10544#else /* ! HAVE_RUBY_ENCODING_H */ 10545#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION >= 1) 10546static VALUE 10547create_encoding_table_core(arg, interp) 10548 VALUE arg; 10549 VALUE interp; 10550{ 10551 struct tcltkip *ptr = get_ip(interp); 10552 volatile VALUE table = rb_hash_new(); 10553 volatile VALUE encname = Qnil; 10554 int i, objc; 10555 Tcl_Obj **objv; 10556 Tcl_Obj *enc_list; 10557 10558 rb_secure(4); 10559 10560 /* set 'binary' encoding */ 10561 rb_hash_aset(table, ENCODING_NAME_BINARY, ENCODING_NAME_BINARY); 10562 10563 /* get Tcl's encoding list */ 10564 Tcl_GetEncodingNames(ptr->ip); 10565 enc_list = Tcl_GetObjResult(ptr->ip); 10566 Tcl_IncrRefCount(enc_list); 10567 10568 if (Tcl_ListObjGetElements(ptr->ip, enc_list, &objc, &objv) != TCL_OK) { 10569 Tcl_DecrRefCount(enc_list); 10570 rb_raise(rb_eRuntimeError, "failt to get Tcl's encoding names"); 10571 } 10572 10573 /* get encoding name and set it to table */ 10574 for(i = 0; i < objc; i++) { 10575 encname = rb_obj_freeze(rb_str_new2(Tcl_GetString(objv[i]))); 10576 rb_hash_aset(table, encname, encname); 10577 } 10578 10579 Tcl_DecrRefCount(enc_list); 10580 10581 rb_ivar_set(table, ID_at_interp, interp); 10582 rb_ivar_set(interp, ID_encoding_table, table); 10583 10584 return table; 10585} 10586 10587#else /* Tcl/Tk 7.x or 8.0 */ 10588static VALUE 10589create_encoding_table_core(arg, interp) 10590 VALUE arg; 10591 VALUE interp; 10592{ 10593 volatile VALUE table = rb_hash_new(); 10594 rb_secure(4); 10595 rb_ivar_set(interp, ID_encoding_table, table); 10596 return table; 10597} 10598#endif 10599#endif 10600 10601static VALUE 10602create_encoding_table(interp) 10603 VALUE interp; 10604{ 10605 return rb_funcall(rb_proc_new(create_encoding_table_core, interp), 10606 ID_call, 0); 10607} 10608 10609static VALUE 10610ip_get_encoding_table(interp) 10611 VALUE interp; 10612{ 10613 volatile VALUE table = Qnil; 10614 10615 table = rb_ivar_get(interp, ID_encoding_table); 10616 10617 if (NIL_P(table)) { 10618 /* initialize encoding_table */ 10619 table = create_encoding_table(interp); 10620 rb_define_singleton_method(table, "get_name", encoding_table_get_name, 1); 10621 rb_define_singleton_method(table, "get_obj", encoding_table_get_obj, 1); 10622 } 10623 10624 return table; 10625} 10626 10627 10628/*###############################################*/ 10629 10630/* 10631 * The following is based on tkMenu.[ch] 10632 * of Tcl/Tk (Tk8.0 -- Tk8.5b1) source code. 10633 */ 10634#if TCL_MAJOR_VERSION >= 8 10635 10636#define MASTER_MENU 0 10637#define TEAROFF_MENU 1 10638#define MENUBAR 2 10639 10640struct dummy_TkMenuEntry { 10641 int type; 10642 struct dummy_TkMenu *menuPtr; 10643 /* , and etc. */ 10644}; 10645 10646struct dummy_TkMenu { 10647 Tk_Window tkwin; 10648 Display *display; 10649 Tcl_Interp *interp; 10650 Tcl_Command widgetCmd; 10651 struct dummy_TkMenuEntry **entries; 10652 int numEntries; 10653 int active; 10654 int menuType; /* MASTER_MENU, TEAROFF_MENU, or MENUBAR */ 10655 Tcl_Obj *menuTypePtr; 10656 /* , and etc. */ 10657}; 10658 10659struct dummy_TkMenuRef { 10660 struct dummy_TkMenu *menuPtr; 10661 char *dummy1; 10662 char *dummy2; 10663 char *dummy3; 10664}; 10665 10666#if 0 /* was available on Tk8.0 -- Tk8.4 */ 10667EXTERN struct dummy_TkMenuRef *TkFindMenuReferences(Tcl_Interp*, char*); 10668#else /* based on Tk8.0 -- Tk8.5.0 */ 10669#define MENU_HASH_KEY "tkMenus" 10670#endif 10671 10672#endif 10673 10674static VALUE 10675ip_make_menu_embeddable_core(interp, argc, argv) 10676 VALUE interp; 10677 int argc; 10678 VALUE *argv; 10679{ 10680#if TCL_MAJOR_VERSION >= 8 10681 volatile VALUE menu_path; 10682 struct tcltkip *ptr = get_ip(interp); 10683 struct dummy_TkMenuRef *menuRefPtr = NULL; 10684 XEvent event; 10685 Tcl_HashTable *menuTablePtr; 10686 Tcl_HashEntry *hashEntryPtr; 10687 10688 menu_path = argv[0]; 10689 StringValue(menu_path); 10690 10691#if 0 /* was available on Tk8.0 -- Tk8.4 */ 10692 menuRefPtr = TkFindMenuReferences(ptr->ip, RSTRING_PTR(menu_path)); 10693#else /* based on Tk8.0 -- Tk8.5b1 */ 10694 if ((menuTablePtr 10695 = (Tcl_HashTable *) Tcl_GetAssocData(ptr->ip, MENU_HASH_KEY, NULL)) 10696 != NULL) { 10697 if ((hashEntryPtr 10698 = Tcl_FindHashEntry(menuTablePtr, RSTRING_PTR(menu_path))) 10699 != NULL) { 10700 menuRefPtr = (struct dummy_TkMenuRef *) Tcl_GetHashValue(hashEntryPtr); 10701 } 10702 } 10703#endif 10704 10705 if (menuRefPtr == (struct dummy_TkMenuRef *) NULL) { 10706 rb_raise(rb_eArgError, "not a menu widget, or invalid widget path"); 10707 } 10708 10709 if (menuRefPtr->menuPtr == (struct dummy_TkMenu *) NULL) { 10710 rb_raise(rb_eRuntimeError, 10711 "invalid menu widget (maybe already destroyed)"); 10712 } 10713 10714 if ((menuRefPtr->menuPtr)->menuType != MENUBAR) { 10715 rb_raise(rb_eRuntimeError, 10716 "target menu widget must be a MENUBAR type"); 10717 } 10718 10719 (menuRefPtr->menuPtr)->menuType = TEAROFF_MENU; 10720#if 0 /* cause SEGV */ 10721 { 10722 /* char *s = "tearoff"; */ 10723 char *s = "normal"; 10724 /* Tcl_SetStringObj((menuRefPtr->menuPtr)->menuTypePtr, s, strlen(s));*/ 10725 (menuRefPtr->menuPtr)->menuTypePtr = Tcl_NewStringObj(s, strlen(s)); 10726 /* Tcl_IncrRefCount((menuRefPtr->menuPtr)->menuTypePtr); */ 10727 /* (menuRefPtr->menuPtr)->menuType = TEAROFF_MENU; */ 10728 (menuRefPtr->menuPtr)->menuType = MASTER_MENU; 10729 } 10730#endif 10731 10732#if 0 /* was available on Tk8.0 -- Tk8.4 */ 10733 TkEventuallyRecomputeMenu(menuRefPtr->menuPtr); 10734 TkEventuallyRedrawMenu(menuRefPtr->menuPtr, 10735 (struct dummy_TkMenuEntry *)NULL); 10736#else /* based on Tk8.0 -- Tk8.5b1 */ 10737 memset((void *) &event, 0, sizeof(event)); 10738 event.xany.type = ConfigureNotify; 10739 event.xany.serial = NextRequest(Tk_Display((menuRefPtr->menuPtr)->tkwin)); 10740 event.xany.send_event = 0; /* FALSE */ 10741 event.xany.window = Tk_WindowId((menuRefPtr->menuPtr)->tkwin); 10742 event.xany.display = Tk_Display((menuRefPtr->menuPtr)->tkwin); 10743 event.xconfigure.window = event.xany.window; 10744 Tk_HandleEvent(&event); 10745#endif 10746 10747#else /* TCL_MAJOR_VERSION <= 7 */ 10748 rb_notimplement(); 10749#endif 10750 10751 return interp; 10752} 10753 10754static VALUE 10755ip_make_menu_embeddable(interp, menu_path) 10756 VALUE interp; 10757 VALUE menu_path; 10758{ 10759 VALUE argv[1]; 10760 10761 argv[0] = menu_path; 10762 return tk_funcall(ip_make_menu_embeddable_core, 1, argv, interp); 10763} 10764 10765 10766/*###############################################*/ 10767 10768/*---- initialization ----*/ 10769void 10770Init_tcltklib() 10771{ 10772 int ret; 10773 10774 VALUE lib = rb_define_module("TclTkLib"); 10775 VALUE ip = rb_define_class("TclTkIp", rb_cObject); 10776 10777 VALUE ev_flag = rb_define_module_under(lib, "EventFlag"); 10778 VALUE var_flag = rb_define_module_under(lib, "VarAccessFlag"); 10779 VALUE release_type = rb_define_module_under(lib, "RELEASE_TYPE"); 10780 10781 /* --------------------------------------------------------------- */ 10782 10783 tcltkip_class = ip; 10784 10785 /* --------------------------------------------------------------- */ 10786 10787#ifdef HAVE_RUBY_ENCODING_H 10788 rb_global_variable(&cRubyEncoding); 10789 cRubyEncoding = rb_path2class("Encoding"); 10790 10791 ENCODING_INDEX_UTF8 = rb_enc_to_index(rb_utf8_encoding()); 10792 ENCODING_INDEX_BINARY = rb_enc_find_index("binary"); 10793#endif 10794 10795 rb_global_variable(&ENCODING_NAME_UTF8); 10796 rb_global_variable(&ENCODING_NAME_BINARY); 10797 10798 ENCODING_NAME_UTF8 = rb_obj_freeze(rb_str_new2("utf-8")); 10799 ENCODING_NAME_BINARY = rb_obj_freeze(rb_str_new2("binary")); 10800 10801 /* --------------------------------------------------------------- */ 10802 10803 rb_global_variable(&eTkCallbackReturn); 10804 rb_global_variable(&eTkCallbackBreak); 10805 rb_global_variable(&eTkCallbackContinue); 10806 10807 rb_global_variable(&eventloop_thread); 10808 rb_global_variable(&eventloop_stack); 10809 rb_global_variable(&watchdog_thread); 10810 10811 rb_global_variable(&rbtk_pending_exception); 10812 10813 /* --------------------------------------------------------------- */ 10814 10815 rb_define_const(lib, "COMPILE_INFO", tcltklib_compile_info()); 10816 10817 rb_define_const(lib, "RELEASE_DATE", 10818 rb_obj_freeze(rb_str_new2(tcltklib_release_date))); 10819 10820 rb_define_const(lib, "FINALIZE_PROC_NAME", 10821 rb_str_new2(finalize_hook_name)); 10822 10823 /* --------------------------------------------------------------- */ 10824 10825#ifdef __WIN32__ 10826# define TK_WINDOWING_SYSTEM "win32" 10827#else 10828# ifdef MAC_TCL 10829# define TK_WINDOWING_SYSTEM "classic" 10830# else 10831# ifdef MAC_OSX_TK 10832# define TK_WINDOWING_SYSTEM "aqua" 10833# else 10834# define TK_WINDOWING_SYSTEM "x11" 10835# endif 10836# endif 10837#endif 10838 rb_define_const(lib, "WINDOWING_SYSTEM", 10839 rb_obj_freeze(rb_str_new2(TK_WINDOWING_SYSTEM))); 10840 10841 /* --------------------------------------------------------------- */ 10842 10843 rb_define_const(ev_flag, "NONE", INT2FIX(0)); 10844 rb_define_const(ev_flag, "WINDOW", INT2FIX(TCL_WINDOW_EVENTS)); 10845 rb_define_const(ev_flag, "FILE", INT2FIX(TCL_FILE_EVENTS)); 10846 rb_define_const(ev_flag, "TIMER", INT2FIX(TCL_TIMER_EVENTS)); 10847 rb_define_const(ev_flag, "IDLE", INT2FIX(TCL_IDLE_EVENTS)); 10848 rb_define_const(ev_flag, "ALL", INT2FIX(TCL_ALL_EVENTS)); 10849 rb_define_const(ev_flag, "DONT_WAIT", INT2FIX(TCL_DONT_WAIT)); 10850 10851 /* --------------------------------------------------------------- */ 10852 10853 rb_define_const(var_flag, "NONE", INT2FIX(0)); 10854 rb_define_const(var_flag, "GLOBAL_ONLY", INT2FIX(TCL_GLOBAL_ONLY)); 10855#ifdef TCL_NAMESPACE_ONLY 10856 rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(TCL_NAMESPACE_ONLY)); 10857#else /* probably Tcl7.6 */ 10858 rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(0)); 10859#endif 10860 rb_define_const(var_flag, "LEAVE_ERR_MSG", INT2FIX(TCL_LEAVE_ERR_MSG)); 10861 rb_define_const(var_flag, "APPEND_VALUE", INT2FIX(TCL_APPEND_VALUE)); 10862 rb_define_const(var_flag, "LIST_ELEMENT", INT2FIX(TCL_LIST_ELEMENT)); 10863#ifdef TCL_PARSE_PART1 10864 rb_define_const(var_flag, "PARSE_VARNAME", INT2FIX(TCL_PARSE_PART1)); 10865#else /* probably Tcl7.6 */ 10866 rb_define_const(var_flag, "PARSE_VARNAME", INT2FIX(0)); 10867#endif 10868 10869 /* --------------------------------------------------------------- */ 10870 10871 rb_define_module_function(lib, "get_version", lib_getversion, -1); 10872 rb_define_module_function(lib, "get_release_type_name", 10873 lib_get_reltype_name, -1); 10874 10875 rb_define_const(release_type, "ALPHA", INT2FIX(TCL_ALPHA_RELEASE)); 10876 rb_define_const(release_type, "BETA", INT2FIX(TCL_BETA_RELEASE)); 10877 rb_define_const(release_type, "FINAL", INT2FIX(TCL_FINAL_RELEASE)); 10878 10879 /* --------------------------------------------------------------- */ 10880 10881 eTkCallbackReturn = rb_define_class("TkCallbackReturn", rb_eStandardError); 10882 eTkCallbackBreak = rb_define_class("TkCallbackBreak", rb_eStandardError); 10883 eTkCallbackContinue = rb_define_class("TkCallbackContinue", 10884 rb_eStandardError); 10885 10886 /* --------------------------------------------------------------- */ 10887 10888 eLocalJumpError = rb_const_get(rb_cObject, rb_intern("LocalJumpError")); 10889 10890 eTkLocalJumpError = rb_define_class("TkLocalJumpError", eLocalJumpError); 10891 10892 eTkCallbackRetry = rb_define_class("TkCallbackRetry", eTkLocalJumpError); 10893 eTkCallbackRedo = rb_define_class("TkCallbackRedo", eTkLocalJumpError); 10894 eTkCallbackThrow = rb_define_class("TkCallbackThrow", eTkLocalJumpError); 10895 10896 /* --------------------------------------------------------------- */ 10897 10898 ID_at_enc = rb_intern("@encoding"); 10899 ID_at_interp = rb_intern("@interp"); 10900 ID_encoding_name = rb_intern("encoding_name"); 10901 ID_encoding_table = rb_intern("encoding_table"); 10902 10903 ID_stop_p = rb_intern("stop?"); 10904 ID_alive_p = rb_intern("alive?"); 10905 ID_kill = rb_intern("kill"); 10906 ID_join = rb_intern("join"); 10907 ID_value = rb_intern("value"); 10908 10909 ID_call = rb_intern("call"); 10910 ID_backtrace = rb_intern("backtrace"); 10911 ID_message = rb_intern("message"); 10912 10913 ID_at_reason = rb_intern("@reason"); 10914 ID_return = rb_intern("return"); 10915 ID_break = rb_intern("break"); 10916 ID_next = rb_intern("next"); 10917 10918 ID_to_s = rb_intern("to_s"); 10919 ID_inspect = rb_intern("inspect"); 10920 10921 /* --------------------------------------------------------------- */ 10922 10923 rb_define_module_function(lib, "mainloop", lib_mainloop, -1); 10924 rb_define_module_function(lib, "mainloop_thread?", 10925 lib_evloop_thread_p, 0); 10926 rb_define_module_function(lib, "mainloop_watchdog", 10927 lib_mainloop_watchdog, -1); 10928 rb_define_module_function(lib, "do_thread_callback", 10929 lib_thread_callback, -1); 10930 rb_define_module_function(lib, "do_one_event", lib_do_one_event, -1); 10931 rb_define_module_function(lib, "mainloop_abort_on_exception", 10932 lib_evloop_abort_on_exc, 0); 10933 rb_define_module_function(lib, "mainloop_abort_on_exception=", 10934 lib_evloop_abort_on_exc_set, 1); 10935 rb_define_module_function(lib, "set_eventloop_window_mode", 10936 set_eventloop_window_mode, 1); 10937 rb_define_module_function(lib, "get_eventloop_window_mode", 10938 get_eventloop_window_mode, 0); 10939 rb_define_module_function(lib, "set_eventloop_tick",set_eventloop_tick,1); 10940 rb_define_module_function(lib, "get_eventloop_tick",get_eventloop_tick,0); 10941 rb_define_module_function(lib, "set_no_event_wait", set_no_event_wait, 1); 10942 rb_define_module_function(lib, "get_no_event_wait", get_no_event_wait, 0); 10943 rb_define_module_function(lib, "set_eventloop_weight", 10944 set_eventloop_weight, 2); 10945 rb_define_module_function(lib, "set_max_block_time", set_max_block_time,1); 10946 rb_define_module_function(lib, "get_eventloop_weight", 10947 get_eventloop_weight, 0); 10948 rb_define_module_function(lib, "num_of_mainwindows", 10949 lib_num_of_mainwindows, 0); 10950 10951 /* --------------------------------------------------------------- */ 10952 10953 rb_define_module_function(lib, "_split_tklist", lib_split_tklist, 1); 10954 rb_define_module_function(lib, "_merge_tklist", lib_merge_tklist, -1); 10955 rb_define_module_function(lib, "_conv_listelement", 10956 lib_conv_listelement, 1); 10957 rb_define_module_function(lib, "_toUTF8", lib_toUTF8, -1); 10958 rb_define_module_function(lib, "_fromUTF8", lib_fromUTF8, -1); 10959 rb_define_module_function(lib, "_subst_UTF_backslash", 10960 lib_UTF_backslash, 1); 10961 rb_define_module_function(lib, "_subst_Tcl_backslash", 10962 lib_Tcl_backslash, 1); 10963 10964 rb_define_module_function(lib, "encoding_system", 10965 lib_get_system_encoding, 0); 10966 rb_define_module_function(lib, "encoding_system=", 10967 lib_set_system_encoding, 1); 10968 rb_define_module_function(lib, "encoding", 10969 lib_get_system_encoding, 0); 10970 rb_define_module_function(lib, "encoding=", 10971 lib_set_system_encoding, 1); 10972 10973 /* --------------------------------------------------------------- */ 10974 10975 rb_define_alloc_func(ip, ip_alloc); 10976 rb_define_method(ip, "initialize", ip_init, -1); 10977 rb_define_method(ip, "create_slave", ip_create_slave, -1); 10978 rb_define_method(ip, "slave_of?", ip_is_slave_of_p, 1); 10979 rb_define_method(ip, "make_safe", ip_make_safe, 0); 10980 rb_define_method(ip, "safe?", ip_is_safe_p, 0); 10981 rb_define_method(ip, "allow_ruby_exit?", ip_allow_ruby_exit_p, 0); 10982 rb_define_method(ip, "allow_ruby_exit=", ip_allow_ruby_exit_set, 1); 10983 rb_define_method(ip, "delete", ip_delete, 0); 10984 rb_define_method(ip, "deleted?", ip_is_deleted_p, 0); 10985 rb_define_method(ip, "has_mainwindow?", ip_has_mainwindow_p, 0); 10986 rb_define_method(ip, "invalid_namespace?", ip_has_invalid_namespace_p, 0); 10987 rb_define_method(ip, "_eval", ip_eval, 1); 10988 rb_define_method(ip, "_cancel_eval", ip_cancel_eval, -1); 10989 rb_define_method(ip, "_cancel_eval_unwind", ip_cancel_eval_unwind, -1); 10990 rb_define_method(ip, "_toUTF8", ip_toUTF8, -1); 10991 rb_define_method(ip, "_fromUTF8", ip_fromUTF8, -1); 10992 rb_define_method(ip, "_thread_vwait", ip_thread_vwait, 1); 10993 rb_define_method(ip, "_thread_tkwait", ip_thread_tkwait, 2); 10994 rb_define_method(ip, "_invoke", ip_invoke, -1); 10995 rb_define_method(ip, "_immediate_invoke", ip_invoke_immediate, -1); 10996 rb_define_method(ip, "_return_value", ip_retval, 0); 10997 10998 rb_define_method(ip, "_create_console", ip_create_console, 0); 10999 11000 /* --------------------------------------------------------------- */ 11001 11002 rb_define_method(ip, "create_dummy_encoding_for_tk", 11003 create_dummy_encoding_for_tk, 1); 11004 rb_define_method(ip, "encoding_table", ip_get_encoding_table, 0); 11005 11006 /* --------------------------------------------------------------- */ 11007 11008 rb_define_method(ip, "_get_variable", ip_get_variable, 2); 11009 rb_define_method(ip, "_get_variable2", ip_get_variable2, 3); 11010 rb_define_method(ip, "_set_variable", ip_set_variable, 3); 11011 rb_define_method(ip, "_set_variable2", ip_set_variable2, 4); 11012 rb_define_method(ip, "_unset_variable", ip_unset_variable, 2); 11013 rb_define_method(ip, "_unset_variable2", ip_unset_variable2, 3); 11014 rb_define_method(ip, "_get_global_var", ip_get_global_var, 1); 11015 rb_define_method(ip, "_get_global_var2", ip_get_global_var2, 2); 11016 rb_define_method(ip, "_set_global_var", ip_set_global_var, 2); 11017 rb_define_method(ip, "_set_global_var2", ip_set_global_var2, 3); 11018 rb_define_method(ip, "_unset_global_var", ip_unset_global_var, 1); 11019 rb_define_method(ip, "_unset_global_var2", ip_unset_global_var2, 2); 11020 11021 /* --------------------------------------------------------------- */ 11022 11023 rb_define_method(ip, "_make_menu_embeddable", ip_make_menu_embeddable, 1); 11024 11025 /* --------------------------------------------------------------- */ 11026 11027 rb_define_method(ip, "_split_tklist", ip_split_tklist, 1); 11028 rb_define_method(ip, "_merge_tklist", lib_merge_tklist, -1); 11029 rb_define_method(ip, "_conv_listelement", lib_conv_listelement, 1); 11030 11031 /* --------------------------------------------------------------- */ 11032 11033 rb_define_method(ip, "mainloop", ip_mainloop, -1); 11034 rb_define_method(ip, "mainloop_watchdog", ip_mainloop_watchdog, -1); 11035 rb_define_method(ip, "do_one_event", ip_do_one_event, -1); 11036 rb_define_method(ip, "mainloop_abort_on_exception", 11037 ip_evloop_abort_on_exc, 0); 11038 rb_define_method(ip, "mainloop_abort_on_exception=", 11039 ip_evloop_abort_on_exc_set, 1); 11040 rb_define_method(ip, "set_eventloop_tick", ip_set_eventloop_tick, 1); 11041 rb_define_method(ip, "get_eventloop_tick", ip_get_eventloop_tick, 0); 11042 rb_define_method(ip, "set_no_event_wait", ip_set_no_event_wait, 1); 11043 rb_define_method(ip, "get_no_event_wait", ip_get_no_event_wait, 0); 11044 rb_define_method(ip, "set_eventloop_weight", ip_set_eventloop_weight, 2); 11045 rb_define_method(ip, "get_eventloop_weight", ip_get_eventloop_weight, 0); 11046 rb_define_method(ip, "set_max_block_time", set_max_block_time, 1); 11047 rb_define_method(ip, "restart", ip_restart, 0); 11048 11049 /* --------------------------------------------------------------- */ 11050 11051 eventloop_thread = Qnil; 11052 eventloop_interp = (Tcl_Interp*)NULL; 11053 11054#ifndef DEFAULT_EVENTLOOP_DEPTH 11055#define DEFAULT_EVENTLOOP_DEPTH 7 11056#endif 11057 eventloop_stack = rb_ary_new2(DEFAULT_EVENTLOOP_DEPTH); 11058 RbTk_OBJ_UNTRUST(eventloop_stack); 11059 11060 watchdog_thread = Qnil; 11061 11062 rbtk_pending_exception = Qnil; 11063 11064 /* --------------------------------------------------------------- */ 11065 11066#ifdef HAVE_NATIVETHREAD 11067 /* if ruby->nativethread-supprt and tcltklib->doen't, 11068 the following will cause link-error. */ 11069 ruby_native_thread_p(); 11070#endif 11071 11072 /* --------------------------------------------------------------- */ 11073 11074 rb_set_end_proc(lib_mark_at_exit, 0); 11075 11076 /* --------------------------------------------------------------- */ 11077 11078 ret = ruby_open_tcl_dll(rb_argv0 ? RSTRING_PTR(rb_argv0) : 0); 11079 switch(ret) { 11080 case TCLTK_STUBS_OK: 11081 break; 11082 case NO_TCL_DLL: 11083 rb_raise(rb_eLoadError, "tcltklib: fail to open tcl_dll"); 11084 case NO_FindExecutable: 11085 rb_raise(rb_eLoadError, "tcltklib: can't find Tcl_FindExecutable"); 11086 default: 11087 rb_raise(rb_eLoadError, "tcltklib: unknown error(%d) on ruby_open_tcl_dll", ret); 11088 } 11089 11090 /* --------------------------------------------------------------- */ 11091 11092#if defined CREATE_RUBYTK_KIT || defined CREATE_RUBYKIT 11093 setup_rubytkkit(); 11094#endif 11095 11096 /* --------------------------------------------------------------- */ 11097 11098 /* Tcl stub check */ 11099 tcl_stubs_check(); 11100 11101 Tcl_ObjType_ByteArray = Tcl_GetObjType(Tcl_ObjTypeName_ByteArray); 11102 Tcl_ObjType_String = Tcl_GetObjType(Tcl_ObjTypeName_String); 11103 11104 /* --------------------------------------------------------------- */ 11105 11106 (void)call_original_exit; 11107} 11108 11109/* eof */ 11110