ext/tcltklib/tcltklib.c

DEFINITIONS

1. _timer_for_tcl
2. set_eventloop_tick
3. get_eventloop_tick
4. set_eventloop_weight
5. get_eventloop_weight
6. lib_mainloop_core
7. lib_mainloop_ensure
8. lib_mainloop_launcher
9. lib_mainloop
10. lib_watchdog_core
11. lib_watchdog_ensure
12. lib_mainloop_watchdog
13. lib_do_one_event
14. get_ip
15. ip_eval_rescue
16. lib_restart
17. ip_ruby
18. ip_free
19. ip_alloc
20. ip_init
21. ip_eval
22. ip_toUTF8
23. ip_fromUTF8
24. ip_invoke_real
25. ivq_safelevel_handler
26. invoke_queue_handler
27. ip_invoke
28. ip_retval
29. _macinit
30. Init_tcltklib

   1  /*
   2   *      tcltklib.c
   3   *              Aug. 27, 1997   Y. Shigehiro
   4   *              Oct. 24, 1997   Y. Matsumoto
   5   */
   6  
   7  #include "ruby.h"
   8  #include "rubysig.h"
   9  #undef EXTERN   /* avoid conflict with tcl.h of tcl8.2 or before */
  10  #include <stdio.h>
  11  #include <string.h>
  12  #include <tcl.h>
  13  #include <tk.h>
  14  
  15  #ifdef __MACOS__
  16  # include <tkMac.h>
  17  # include <Quickdraw.h>
  18  #endif
  19  
  20  /* for ruby_debug */
  21  
  22  #define DUMP1(ARG1) if (ruby_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1);}
  23  #define DUMP2(ARG1, ARG2) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\
  24  fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); }
  25  /*
  26  #define DUMP1(ARG1)
  27  #define DUMP2(ARG1, ARG2)
  28  */
  29  
  30  /* for callback break & continue */
  31  static VALUE eTkCallbackBreak;
  32  static VALUE eTkCallbackContinue;
  33  
  34  static VALUE ip_invoke_real _((int, VALUE*, VALUE));
  35  
  36  /* from tkAppInit.c */
  37  
  38  #if !defined __MINGW32__
  39  /*
  40   * The following variable is a special hack that is needed in order for
  41   * Sun shared libraries to be used for Tcl.
  42   */
  43  
  44  extern int matherr();
  45  int *tclDummyMathPtr = (int *) matherr;
  46  #endif
  47  
  48  /*---- module TclTkLib ----*/
  49  
  50  struct invoke_queue {
  51      Tcl_Event ev;
  52      int argc;
  53      VALUE *argv;
  54      VALUE obj;
  55      int done;
  56      int safe_level;
  57      VALUE *result;
  58      VALUE thread;
  59  };
  60   
  61  static VALUE main_thread;
  62  static VALUE eventloop_thread;
  63  static VALUE watchdog_thread;
  64  Tcl_Interp  *current_interp;
  65  
  66  /* 
  67   *  'event_loop_max' is a maximum events which the eventloop processes in one 
  68   *  term of thread scheduling. 'no_event_tick' is the count-up value when 
  69   *  there are no event for processing. 
  70   *  'timer_tick' is a limit of one term of thread scheduling. 
  71   *  If 'timer_tick' == 0, then not use the timer for thread scheduling.
  72   */
  73  static int tick_counter;
  74  #define DEFAULT_EVENT_LOOP_MAX  800
  75  #define DEFAULT_NO_EVENT_TICK    10
  76  #define DEFAULT_TIMER_TICK        0
  77  static int event_loop_max = DEFAULT_EVENT_LOOP_MAX;
  78  static int no_event_tick  = DEFAULT_NO_EVENT_TICK;
  79  static int timer_tick     = DEFAULT_TIMER_TICK;
  80  
  81  #if TCL_MAJOR_VERSION >= 8
  82  static int ip_ruby _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*));
  83  #else
  84  static int ip_ruby _((ClientData, Tcl_Interp *, int, char **));
  85  #endif
  86  
  87  /* Tk_ThreadTimer */
  88  static Tcl_TimerToken timer_token = (Tcl_TimerToken)NULL;
  89  
  90  /* timer callback */
  91  static void _timer_for_tcl _((ClientData));
  92  static void
  93  _timer_for_tcl(clientData)
  94      ClientData clientData;
  95  {
  96      struct invoke_queue *q, *tmp;
  97      VALUE thread;
  98  
  99      Tk_DeleteTimerHandler(timer_token);
 100      if (timer_tick > 0) {
 101        timer_token = Tk_CreateTimerHandler(timer_tick, _timer_for_tcl, 
 102                                            (ClientData)0);
 103      } else {
 104        timer_token = (Tcl_TimerToken)NULL;
 105      }
 106  
 107      /* rb_thread_schedule(); */
 108      timer_tick += event_loop_max;
 109  }
 110  
 111  static VALUE
 112  set_eventloop_tick(self, tick)
 113      VALUE self;
 114      VALUE tick;
 115  {
 116      int ttick = NUM2INT(tick);
 117  
 118      if (ttick < 0) {
rb_raise(rb_eArgError, "timer-tick parameter must be 0 or plus number");
 120      }
 121  
 122      /* delete old timer callback */
 123      Tk_DeleteTimerHandler(timer_token);
 124  
 125      timer_tick = ttick;
 126      if (timer_tick > 0) {
 127        /* start timer callback */
 128        timer_token = Tk_CreateTimerHandler(timer_tick, _timer_for_tcl, 
 129                                            (ClientData)0);
 130      } else {
 131        timer_token = (Tcl_TimerToken)NULL;
 132      }
 133  
 134      return tick;
 135  }
 136  
 137  static VALUE
 138  get_eventloop_tick(self)
 139      VALUE self;
 140  {
 141      return INT2NUM(timer_tick);
 142  }
 143  
 144  static VALUE
 145  set_eventloop_weight(self, loop_max, no_event)
 146      VALUE self;
 147      VALUE loop_max;
 148      VALUE no_event;
 149  {
 150      int lpmax = NUM2INT(loop_max);
 151      int no_ev = NUM2INT(no_event);
 152  
 153      if (lpmax <= 0 || no_ev <= 0) {
rb_raise(rb_eArgError, "weight parameters must be plus number");
 155      }
 156  
 157      event_loop_max = lpmax;
 158      no_event_tick  = no_ev;
 159  
 160      return rb_ary_new3(2, loop_max, no_event);
 161  }
 162  
 163  static VALUE
 164  get_eventloop_weight(self)
 165      VALUE self;
 166  {
 167      return rb_ary_new3(2, INT2NUM(event_loop_max), INT2NUM(no_event_tick));
 168  }
 169  
 170  VALUE
 171  lib_mainloop_core(check_root_widget)
 172      VALUE check_root_widget;
 173  {
 174      VALUE current = eventloop_thread;
 175      int check = (check_root_widget == Qtrue);
 176  
 177      Tk_DeleteTimerHandler(timer_token);
 178      if (timer_tick > 0) {
 179        timer_token = Tk_CreateTimerHandler(timer_tick, _timer_for_tcl, 
 180                                            (ClientData)0);
 181      } else {
 182        timer_token = (Tcl_TimerToken)NULL;
 183      }
 184  
 185      for(;;) {
 186        tick_counter = 0;
 187        while(tick_counter < event_loop_max) {
 188          if (Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT)) {
 189            tick_counter++;
 190          } else {
 191            tick_counter += no_event_tick;
 192          }
 193          if (watchdog_thread != 0 && eventloop_thread != current) {
 194            return Qnil;
 195          }
 196        }
 197        if (check && Tk_GetNumMainWindows() == 0) {
 198          break;
 199        }
rb_thread_schedule();
 201      }
 202      return Qnil;
 203  }
 204  
 205  VALUE
 206  lib_mainloop_ensure(parent_evloop)
 207      VALUE parent_evloop;
 208  {
 209      Tk_DeleteTimerHandler(timer_token);
 210      timer_token = (Tcl_TimerToken)NULL;
DUMP2("mainloop-ensure: current-thread : %lx\n", rb_thread_current());
DUMP2("mainloop-ensure: eventloop-thread : %lx\n", eventloop_thread);
 213      if (eventloop_thread == rb_thread_current()) {
DUMP2("tcltklib: eventloop-thread -> %lx\n", parent_evloop);
 215        eventloop_thread = parent_evloop;
 216      }
 217      return Qnil;
 218  }
 219  
 220  static VALUE
lib_mainloop_launcher(check_rootwidget)
 222      VALUE check_rootwidget;
 223  {
 224      VALUE parent_evloop = eventloop_thread;
 225  
 226      eventloop_thread = rb_thread_current();
 227  
 228      if (ruby_debug) { 
 229        fprintf(stderr, "tcltklib: eventloop-thread : %lx -> %lx\n", 
 230                parent_evloop, eventloop_thread);
 231      }
 232  
 233      return rb_ensure(lib_mainloop_core, check_rootwidget, 
 234                       lib_mainloop_ensure, parent_evloop);
 235  }
 236  
 237  /* execute Tk_MainLoop */
 238  static VALUE
 239  lib_mainloop(argc, argv, self)
 240      int   argc;
 241      VALUE *argv;
 242      VALUE self;
 243  {
 244      VALUE check_rootwidget;
 245  
 246      if (rb_scan_args(argc, argv, "01", &check_rootwidget) == 0) {
 247        check_rootwidget = Qtrue;
 248      } else if (RTEST(check_rootwidget)) {
 249        check_rootwidget = Qtrue;
 250      } else {
 251        check_rootwidget = Qfalse;
 252      }
 253  
 254      return lib_mainloop_launcher(check_rootwidget);
 255  }
 256  
 257  VALUE
 258  lib_watchdog_core(check_rootwidget)
 259      VALUE check_rootwidget;
 260  {
 261      VALUE current = eventloop_thread;
 262      VALUE evloop;
 263      int   check = (check_rootwidget == Qtrue);
 264      ID    stop = rb_intern("stop?");
 265  
 266      /* check other watchdog thread */
 267      if (watchdog_thread != 0) {
 268        if (rb_funcall(watchdog_thread, stop, 0) == Qtrue) {
rb_funcall(watchdog_thread, rb_intern("kill"), 0);
 270        } else {
 271          return Qnil;
 272        }
 273      }
 274      watchdog_thread = rb_thread_current();
 275  
 276      /* watchdog start */
 277      do {
 278        if (eventloop_thread == 0 
 279            || rb_funcall(eventloop_thread, stop, 0) == Qtrue) {
 280          /* start new eventloop thread */
DUMP2("eventloop thread %lx is sleeping or dead", eventloop_thread);
 282          evloop = rb_thread_create(lib_mainloop_launcher, 
 283                                    (void*)&check_rootwidget);
DUMP2("create new eventloop thread %lx", evloop);
rb_thread_run(evloop);
 286        } else {
rb_thread_schedule();
 288        }
 289      } while(!check || Tk_GetNumMainWindows() != 0);
 290  
 291      return Qnil;
 292  }
 293  
 294  VALUE
 295  lib_watchdog_ensure(arg)
 296      VALUE arg;
 297  {
 298      eventloop_thread = 0; /* stop eventloops */
 299      return Qnil;
 300  }
 301  
 302  static VALUE
 303  lib_mainloop_watchdog(argc, argv, self)
 304      int   argc;
 305      VALUE *argv;
 306      VALUE self;
 307  {
 308      VALUE check_rootwidget;
 309  
 310      if (rb_scan_args(argc, argv, "01", &check_rootwidget) == 0) {
 311        check_rootwidget = Qtrue;
 312      } else if (RTEST(check_rootwidget)) {
 313        check_rootwidget = Qtrue;
 314      } else {
 315        check_rootwidget = Qfalse;
 316      }
 317  
 318      return rb_ensure(lib_watchdog_core, check_rootwidget, 
 319                       lib_watchdog_ensure, Qnil);
 320  }
 321  
 322  static VALUE
 323  lib_do_one_event(argc, argv, self)
 324      int   argc;
 325      VALUE *argv;
 326      VALUE self;
 327  {
 328      VALUE obj, vflags;
 329      int flags;
 330  
 331      if (rb_scan_args(argc, argv, "01", &vflags) == 0) {
 332        flags = 0;
 333      } else {
Check_Type(vflags, T_FIXNUM);
 335        flags = FIX2INT(vflags);
 336      }
 337      return INT2NUM(Tcl_DoOneEvent(flags));
 338  }
 339  
 340  /*---- class TclTkIp ----*/
 341  struct tcltkip {
 342      Tcl_Interp *ip;             /* the interpreter */
 343      int return_value;           /* return value */
 344  };
 345  
 346  static struct tcltkip *
get_ip(self)
 348      VALUE self;
 349  {
 350      struct tcltkip *ptr;
 351  
Data_Get_Struct(self, struct tcltkip, ptr);
 353      if (ptr == 0) {
rb_raise(rb_eTypeError, "uninitialized TclTkIp");
 355      }
 356      return ptr;
 357  }
 358  
 359  /* Tcl command `ruby' */
 360  static VALUE
 361  ip_eval_rescue(failed, einfo)
 362      VALUE *failed;
 363      VALUE einfo;
 364  {
 365      *failed = einfo;
 366      return Qnil;
 367  }
 368  
 369  /* restart Tk */
 370  static VALUE
 371  lib_restart(self)
 372      VALUE self;
 373  {
 374      struct tcltkip *ptr = get_ip(self);
 375  
 376      /* destroy the root wdiget */
 377      ptr->return_value = Tcl_Eval(ptr->ip, "destroy .");
 378      /* ignore ERROR */
DUMP2("(TCL_Eval result) %d", ptr->return_value);
 380  
 381      /* execute Tk_Init */
DUMP1("Tk_Init");
 383      if (Tk_Init(ptr->ip) == TCL_ERROR) {
rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
 385      }
 386  
 387      return Qnil;
 388  }
 389  
 390  static int
 391  #if TCL_MAJOR_VERSION >= 8
 392  ip_ruby(clientData, interp, argc, argv)
 393      ClientData clientData;
 394      Tcl_Interp *interp; 
 395      int argc;
 396      Tcl_Obj *CONST argv[];
 397  #else
 398  ip_ruby(clientData, interp, argc, argv)
 399      ClientData clientData;
 400      Tcl_Interp *interp;
 401      int argc;
 402      char *argv[];
 403  #endif
 404  {
 405      VALUE res;
 406      int old_trapflg;
 407      VALUE failed = 0;
 408      char *arg;
 409      int  dummy;
 410  
 411      /* ruby command has 1 arg. */
 412      if (argc != 2) {
rb_raise(rb_eArgError, "wrong # of arguments (%d for 1)", argc);
 414      }
 415  
 416      /* get C string from Tcl object */
 417  #if TCL_MAJOR_VERSION >= 8
 418      arg = Tcl_GetStringFromObj(argv[1], &dummy);
 419  #else
 420      arg = argv[1];
 421  #endif
 422  
 423      /* evaluate the argument string by ruby */
DUMP2("rb_eval_string(%s)", arg);
 425      old_trapflg = rb_trap_immediate;
 426      rb_trap_immediate = 0;
 427      res = rb_rescue2(rb_eval_string, (VALUE)arg,
 428                       ip_eval_rescue, (VALUE)&failed,
 429                       rb_eStandardError, rb_eScriptError, 0);
 430      rb_trap_immediate = old_trapflg;
 431  
 432      Tcl_ResetResult(interp);
 433      if (failed) {
 434          VALUE eclass = CLASS_OF(failed);
 435          Tcl_AppendResult(interp, StringValuePtr(failed), (char*)NULL);
 436          if (eclass == eTkCallbackBreak) {
 437              return TCL_BREAK;
 438          } else if (eclass == eTkCallbackContinue) {
 439              return TCL_CONTINUE;
 440          } else {
 441              return TCL_ERROR;
 442          }
 443      }
 444  
 445      /* result must be string or nil */
 446      if (NIL_P(res)) {
DUMP1("(rb_eval_string result) nil");
 448          return TCL_OK;
 449      }
 450  
 451      /* copy result to the tcl interpreter */
DUMP2("(rb_eval_string result) %s", StringValuePtr(res));
DUMP1("Tcl_AppendResult");
 454      Tcl_AppendResult(interp, StringValuePtr(res), (char *)NULL);
 455  
 456      return TCL_OK;
 457  }
 458  
 459  /* destroy interpreter */
 460  static void
 461  ip_free(ptr)
 462      struct tcltkip *ptr;
 463  {
DUMP1("Tcl_DeleteInterp");
 465      if (ptr) {
 466          Tcl_DeleteInterp(ptr->ip);
 467          free(ptr);
 468      }
 469  }
 470  
 471  /* create and initialize interpreter */
 472  static VALUE
 473  ip_alloc(self)
 474      VALUE self;
 475  {
 476      return Data_Wrap_Struct(self, 0, ip_free, 0);
 477  }
 478  
 479  static VALUE
 480  ip_init(self)
 481      VALUE self;
 482  {
 483      struct tcltkip *ptr;        /* tcltkip data struct */
 484  
 485      /* create object */
Data_Get_Struct(self, struct tcltkip, ptr);
 487      ptr = ALLOC(struct tcltkip);
DATA_PTR(self) = ptr;
 489      ptr->return_value = 0;
 490  
 491      /* from Tk_Main() */
DUMP1("Tcl_CreateInterp");
 493      ptr->ip = Tcl_CreateInterp();
 494      current_interp = ptr->ip;
 495  
 496      /* from Tcl_AppInit() */
DUMP1("Tcl_Init");
 498      if (Tcl_Init(ptr->ip) == TCL_ERROR) {
rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
 500      }
DUMP1("Tk_Init");
 502      if (Tk_Init(ptr->ip) == TCL_ERROR) {
rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
 504      }
DUMP1("Tcl_StaticPackage(\"Tk\")");
 506      Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init,
 507                        (Tcl_PackageInitProc *) NULL);
 508  
 509      /* add ruby command to the interpreter */
 510  #if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"ruby\")");
 512      Tcl_CreateObjCommand(ptr->ip, "ruby", ip_ruby, (ClientData)NULL,
 513                           (Tcl_CmdDeleteProc *)NULL);
 514  #else
DUMP1("Tcl_CreateCommand(\"ruby\")");
 516      Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby, (ClientData)NULL,
 517                        (Tcl_CmdDeleteProc *)NULL);
 518  #endif
 519  
 520      return self;
 521  }
 522  
 523  /* eval string in tcl by Tcl_Eval() */
 524  static VALUE
 525  ip_eval(self, str)
 526      VALUE self;
 527      VALUE str;
 528  {
 529      char *s;
 530      char *buf;                  /* Tcl_Eval requires re-writable string region */
 531      struct tcltkip *ptr = get_ip(self);
 532  
 533      /* call Tcl_Eval() */
 534      s = StringValuePtr(str);
 535      buf = ALLOCA_N(char, strlen(s)+1);
 536      strcpy(buf, s);
DUMP2("Tcl_Eval(%s)", buf);
 538      ptr->return_value = Tcl_Eval(ptr->ip, buf);
 539      if (ptr->return_value == TCL_ERROR) {
rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
 541      }
DUMP2("(TCL_Eval result) %d", ptr->return_value);
 543  
 544      /* pass back the result (as string) */
 545      return(rb_str_new2(ptr->ip->result));
 546  }
 547  
 548  
 549  static VALUE
 550  ip_toUTF8(self, str, encodename)
 551      VALUE self;
 552      VALUE str;
 553      VALUE encodename;
 554  {
 555  #ifdef TCL_UTF_MAX
 556      Tcl_Interp *interp;
 557      Tcl_Encoding encoding;
 558      Tcl_DString dstr;
 559      struct tcltkip *ptr;
 560      char *buf;
 561  
 562      ptr = get_ip(self);
 563      interp = ptr->ip;
 564  
StringValue(encodename);
StringValue(str);
 567      encoding = Tcl_GetEncoding(interp, RSTRING(encodename)->ptr);
 568      if (!RSTRING(str)->len) return str;
 569      buf = ALLOCA_N(char,strlen(RSTRING(str)->ptr)+1);
 570      strcpy(buf, RSTRING(str)->ptr);
 571  
 572      Tcl_DStringInit(&dstr);
 573      Tcl_DStringFree(&dstr);
 574      Tcl_ExternalToUtfDString(encoding,buf,strlen(buf),&dstr);
 575      str = rb_str_new2(Tcl_DStringValue(&dstr));
 576  
 577      Tcl_FreeEncoding(encoding);
 578      Tcl_DStringFree(&dstr);
 579  #endif
 580      return str;
 581  }
 582  
 583  static VALUE
 584  ip_fromUTF8(self, str, encodename)
 585      VALUE self;
 586      VALUE str;
 587      VALUE encodename;
 588  {
 589  #ifdef TCL_UTF_MAX
 590      Tcl_Interp *interp;
 591      Tcl_Encoding encoding;
 592      Tcl_DString dstr;
 593      struct tcltkip *ptr;
 594      char *buf;
 595  
 596      ptr = get_ip(self);
 597      interp = ptr->ip;
 598  
StringValue(encodename);
StringValue(str);
 601      encoding = Tcl_GetEncoding(interp,RSTRING(encodename)->ptr);
 602      if (!RSTRING(str)->len) return str;
 603      buf = ALLOCA_N(char,strlen(RSTRING(str)->ptr)+1);
 604      strcpy(buf,RSTRING(str)->ptr);
 605  
 606      Tcl_DStringInit(&dstr);
 607      Tcl_DStringFree(&dstr);
 608      Tcl_UtfToExternalDString(encoding,buf,strlen(buf),&dstr);
 609      str = rb_str_new2(Tcl_DStringValue(&dstr));
 610  
 611      Tcl_FreeEncoding(encoding);
 612      Tcl_DStringFree(&dstr);
 613  
 614  #endif
 615      return str;
 616  }
 617  
 618  
 619  static VALUE
ip_invoke_real(argc, argv, obj)
 621      int argc;
 622      VALUE *argv;
 623      VALUE obj;
 624  {
 625      VALUE v;
 626      struct tcltkip *ptr;        /* tcltkip data struct */
 627      int i;
 628      Tcl_CmdInfo info;
 629      char *cmd, *s;
 630      char **av = (char **)NULL;
 631  #if TCL_MAJOR_VERSION >= 8
 632      Tcl_Obj **ov = (Tcl_Obj **)NULL;
 633      Tcl_Obj *resultPtr;
 634  #endif
 635  
 636      /* get the data struct */
 637      ptr = get_ip(obj);
 638  
 639      /* get the command name string */
 640      v = argv[0];
 641      cmd = StringValuePtr(v);
 642  
 643      /* map from the command name to a C procedure */
 644      if (!Tcl_GetCommandInfo(ptr->ip, cmd, &info)) {
rb_raise(rb_eNameError, "invalid command name `%s'", cmd);
 646      }
 647  
 648      /* memory allocation for arguments of this command */
 649  #if TCL_MAJOR_VERSION >= 8
 650      if (info.isNativeObjectProc) {
 651          /* object interface */
 652          ov = (Tcl_Obj **)ALLOCA_N(Tcl_Obj *, argc+1);
 653          for (i = 0; i < argc; ++i) {
 654              v = argv[i];
 655              s = StringValuePtr(v);
 656              ov[i] = Tcl_NewStringObj(s, RSTRING(v)->len);
 657              Tcl_IncrRefCount(ov[i]);
 658          }
 659          ov[argc] = (Tcl_Obj *)NULL;
 660      } 
 661      else
 662  #endif
 663      {
 664        /* string interface */
 665          av = (char **)ALLOCA_N(char *, argc+1);
 666          for (i = 0; i < argc; ++i) {
 667              v = argv[i];
 668              s = StringValuePtr(v);
 669              av[i] = ALLOCA_N(char, strlen(s)+1);
 670              strcpy(av[i], s);
 671          }
 672          av[argc] = (char *)NULL;
 673      }
 674  
 675      Tcl_ResetResult(ptr->ip);
 676  
 677      /* Invoke the C procedure */
 678  #if TCL_MAJOR_VERSION >= 8
 679      if (info.isNativeObjectProc) {
 680          int dummy;
 681          ptr->return_value = (*info.objProc)(info.objClientData,
 682                                              ptr->ip, argc, ov);
 683  
 684          /* get the string value from the result object */
 685          resultPtr = Tcl_GetObjResult(ptr->ip);
 686          Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &dummy),
 687                        TCL_VOLATILE);
 688  
 689          for (i=0; i<argc; i++) {
 690              Tcl_DecrRefCount(ov[i]);
 691          }
 692      }
 693      else
 694  #endif
 695      {
 696          ptr->return_value = (*info.proc)(info.clientData,
 697                                           ptr->ip, argc, av);
 698      }
 699  
 700      if (ptr->return_value == TCL_ERROR) {
rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
 702      }
 703  
 704      /* pass back the result (as string) */
 705      return rb_str_new2(ptr->ip->result);
 706  }
 707  
 708  VALUE
 709  ivq_safelevel_handler(arg, ivq)
 710      VALUE arg;
 711      VALUE ivq;
 712  {
 713      struct invoke_queue *q;
 714  
Data_Get_Struct(ivq, struct invoke_queue, q);
DUMP2("(safe-level handler) $SAFE = %d", q->safe_level);
rb_set_safe_level(q->safe_level);
 718      return ip_invoke_real(q->argc, q->argv, q->obj);
 719  }
 720  
 721  int invoke_queue_handler _((Tcl_Event *, int));
 722  int
 723  invoke_queue_handler(evPtr, flags)
 724      Tcl_Event *evPtr;
 725      int flags;
 726  {
 727      struct invoke_queue *tmp, *q = (struct invoke_queue *)evPtr;
 728  
DUMP1("do_invoke_queue_handler");
DUMP2("invoke queue_thread : %lx", rb_thread_current());
DUMP2("added by thread : %lx", q->thread);
 732  
 733      if (q->done) {
 734        /* processed by another event-loop */
 735        return 0;
 736      }
 737  
 738      /* process it */
 739      q->done = 1;
 740  
 741      /* check safe-level */
 742      if (rb_safe_level() != q->safe_level) {
 743        *(q->result) = rb_funcall(rb_proc_new(ivq_safelevel_handler, 
Data_Wrap_Struct(rb_cData,0,0,q)), 
rb_intern("call"), 0);
 746      } else {
 747        *(q->result) = ip_invoke_real(q->argc, q->argv, q->obj);
 748      }
 749  
 750      /* back to caller */
rb_thread_run(q->thread);
 752  
 753      /* end of handler : remove it */
 754      return 1;
 755  }
 756  
 757  static VALUE
 758  ip_invoke(argc, argv, obj)
 759      int argc;
 760      VALUE *argv;
 761      VALUE obj;
 762  {
 763      struct invoke_queue *tmp;
 764      VALUE current = rb_thread_current();
 765      VALUE result;
 766      VALUE *alloc_argv, *alloc_result;
 767      Tcl_QueuePosition position;
 768  
 769      if (eventloop_thread == 0 || current == eventloop_thread) {
DUMP2("invoke from current eventloop %lx", current);
 771        return ip_invoke_real(argc, argv, obj);
 772      }
 773  
DUMP2("invoke from thread %lx (NOT current eventloop)", current);
 775  
 776      /* allocate memory (protected from Tcl_ServiceEvent) */
 777      alloc_argv =  ALLOC_N(VALUE,argc);
MEMCPY(alloc_argv, argv, VALUE, argc);
 779      alloc_result = ALLOC(VALUE);
 780  
 781      /* allocate memory (freed by Tcl_ServiceEvent */
 782      tmp = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue));
 783  
 784      /* construct event data */
 785      tmp->done = 0;
 786      tmp->obj = obj;
 787      tmp->argc = argc;
 788      tmp->argv = alloc_argv;
 789      tmp->result = alloc_result;
 790      tmp->thread = current;
 791      tmp->safe_level = rb_safe_level();
 792      tmp->ev.proc = invoke_queue_handler;
 793      position = TCL_QUEUE_TAIL;
 794  
 795      /* add the handler to Tcl event queue */
 796      Tcl_QueueEvent(&tmp->ev, position);
 797  
 798      /* wait for the handler to be processed */
rb_thread_stop();
 800  
 801      /* get result & free allocated memory */
 802      result = *alloc_result;
 803      free(alloc_argv);
 804      free(alloc_result);
 805  
 806      return result;
 807  }
 808  
 809  /* get return code from Tcl_Eval() */
 810  static VALUE
 811  ip_retval(self)
 812      VALUE self;
 813  {
 814      struct tcltkip *ptr;        /* tcltkip data struct */
 815  
 816      /* get the data strcut */
 817      ptr = get_ip(self);
 818  
 819      return (INT2FIX(ptr->return_value));
 820  }
 821  
 822  #ifdef __MACOS__
 823  static void
_macinit()
 825  {
 826      tcl_macQdPtr = &qd; /* setup QuickDraw globals */
 827      Tcl_MacSetEventProc(TkMacConvertEvent); /* setup event handler */
 828  }
 829  #endif
 830  
 831  /*---- initialization ----*/
 832  void
 833  Init_tcltklib()
 834  {
 835      VALUE lib = rb_define_module("TclTkLib");
 836      VALUE ip = rb_define_class("TclTkIp", rb_cObject);
 837  
 838      VALUE ev_flag = rb_define_module_under(lib, "EventFlag");
 839  
 840  #if defined USE_TCL_STUBS && defined USE_TK_STUBS
 841      extern int ruby_tcltk_stubs();
 842      int ret = ruby_tcltk_stubs();
 843      if (ret)
rb_raise(rb_eLoadError, "tcltklib: tcltk_stubs init error(%d)", ret);
 845  #endif
 846  
rb_define_const(ev_flag, "WINDOW",    INT2FIX(TCL_WINDOW_EVENTS));
rb_define_const(ev_flag, "FILE",      INT2FIX(TCL_FILE_EVENTS));
rb_define_const(ev_flag, "TIMER",     INT2FIX(TCL_TIMER_EVENTS));
rb_define_const(ev_flag, "IDLE",      INT2FIX(TCL_IDLE_EVENTS));
rb_define_const(ev_flag, "ALL",       INT2FIX(TCL_ALL_EVENTS));
rb_define_const(ev_flag, "DONT_WAIT", INT2FIX(TCL_DONT_WAIT));
 853  
 854      eTkCallbackBreak = rb_define_class("TkCallbackBreak", rb_eStandardError);
 855      eTkCallbackContinue = rb_define_class("TkCallbackContinue",rb_eStandardError);
 856  
rb_define_module_function(lib, "mainloop", lib_mainloop, -1);
rb_define_module_function(lib, "mainloop_watchdog", 
 859                                lib_mainloop_watchdog, -1);
rb_define_module_function(lib, "do_one_event", lib_do_one_event, -1);
rb_define_module_function(lib, "set_eventloop_tick",set_eventloop_tick,1);
rb_define_module_function(lib, "get_eventloop_tick",get_eventloop_tick,0);
rb_define_module_function(lib, "set_eventloop_weight", 
 864                                set_eventloop_weight, 2);
rb_define_module_function(lib, "get_eventloop_weight", 
 866                                get_eventloop_weight, 0);
 867  
rb_define_singleton_method(ip, "allocate", ip_alloc, 0);
rb_define_method(ip, "initialize", ip_init, 0);
rb_define_method(ip, "_eval", ip_eval, 1);
rb_define_method(ip, "_toUTF8",ip_toUTF8,2);
rb_define_method(ip, "_fromUTF8",ip_fromUTF8,2);
rb_define_method(ip, "_invoke", ip_invoke, -1);
rb_define_method(ip, "_return_value", ip_retval, 0);
rb_define_method(ip, "mainloop", lib_mainloop, -1);
rb_define_method(ip, "mainloop_watchdog", lib_mainloop_watchdog, -1);
rb_define_method(ip, "do_one_event", lib_do_one_event, -1);
rb_define_method(ip, "set_eventloop_tick", set_eventloop_tick, 1);
rb_define_method(ip, "get_eventloop_tick", get_eventloop_tick, 0);
rb_define_method(ip, "set_eventloop_weight", set_eventloop_weight, 2);
rb_define_method(ip, "get_eventloop_weight", get_eventloop_weight, 0);
rb_define_method(ip, "restart", lib_restart, 0);
 883  
 884      main_thread = rb_thread_current();
 885      eventloop_thread = 0;
 886      watchdog_thread  = 0;
 887  
 888  #ifdef __MACOS__
_macinit();
 890  #endif
 891  
 892      /*---- initialize tcl/tk libraries ----*/
 893      /* from Tk_Main() */
DUMP1("Tcl_FindExecutable");
 895      Tcl_FindExecutable(RSTRING(rb_argv0)->ptr);
 896  }
 897  
 898  /* eof */