Commit message: tcltklib.c: check argument

* ext/tk/tcltklib.c (ip_cancel_eval_core): check argument type and
  length.

git-svn-id: svn+ssh://ci.ruby-lang.org/ruby/trunk@51468 b2dd03c8-39d4-4d8f-98ff-823fe69b080e
CVE: CVE-2016-2337
CWE: NVD-CWE-Other
Vulnerability description: Type confusion exists in _cancel_eval Ruby's TclTkIp class method. Attacker passing different type of object than String as "retval" argument can cause arbitrary code execution.

Project: tk
File: tcltklib.c

setup_rubytkkit(void)
{
  init_static_tcltk_packages();

  {
    ID const_id;
    const_id = rb_intern(RUBYTK_KITPATH_CONST_NAME);

    if (rb_const_defined(rb_cObject, const_id)) {
      volatile VALUE pathobj;
      pathobj = rb_const_get(rb_cObject, const_id);

      if (rb_obj_is_kind_of(pathobj, rb_cString)) {
#ifdef HAVE_RUBY_ENCODING_H
	pathobj = rb_str_export_to_enc(pathobj, rb_utf8_encoding());
#endif
	set_rubytk_kitpath(RSTRING_PTR(pathobj));
      }
    }
  }

#ifdef CREATE_RUBYTK_KIT
  if (rubytk_kitpath == NULL) {
#ifdef __WIN32__
    /* rbtk_win32_SetHINSTANCE("tcltklib.so"); */
    {
      volatile VALUE basename;
      basename = rb_funcall(rb_cFile, rb_intern("basename"), 1,
			    rb_str_new2(rb_sourcefile()));
      rbtk_win32_SetHINSTANCE(RSTRING_PTR(basename));
    }
#endif
    set_rubytk_kitpath(rb_sourcefile());
  }
#endif

  if (rubytk_kitpath == NULL) {
    set_rubytk_kitpath(Tcl_GetNameOfExecutable());
  }

  TclSetPreInitScript(rubytkkit_preInitCmd);
}

Project: tk
File: tcltklib.c

set_max_block_time(self, time)
    VALUE self;
    VALUE time;
{
    struct Tcl_Time tcl_time;
    VALUE divmod;

    switch(TYPE(time)) {
    case T_FIXNUM:
    case T_BIGNUM:
        /* time is micro-second value */
        divmod = rb_funcall(time, rb_intern("divmod"), 1, LONG2NUM(1000000));
        tcl_time.sec  = NUM2LONG(RARRAY_PTR(divmod)[0]);
        tcl_time.usec = NUM2LONG(RARRAY_PTR(divmod)[1]);
        break;

    case T_FLOAT:
        /* time is second value */
        divmod = rb_funcall(time, rb_intern("divmod"), 1, INT2FIX(1));
        tcl_time.sec  = NUM2LONG(RARRAY_PTR(divmod)[0]);
        tcl_time.usec = (long)(NUM2DBL(RARRAY_PTR(divmod)[1]) * 1000000);

    default:
        {
	    VALUE tmp = rb_funcallv(time, ID_inspect, 0, 0);
	    rb_raise(rb_eArgError, "invalid value for time: '%s'",
		     StringValuePtr(tmp));
	}
    }

    Tcl_SetMaxBlockTime(&tcl_time);

    return Qnil;
}

Project: tk
File: tcltklib.c

invoke_queue_handler(evPtr, flags)
    Tcl_Event *evPtr;
    int flags;
{
    struct invoke_queue *q = (struct invoke_queue *)evPtr;
    volatile VALUE ret;
    volatile VALUE q_dat;
    volatile VALUE thread = q->thread;
    struct tcltkip *ptr;

    DUMP2("do_invoke_queue_handler : evPtr = %p", evPtr);
    DUMP2("invoke queue_thread : %"PRIxVALUE, rb_thread_current());
    DUMP2("added by thread : %"PRIxVALUE, thread);

    if (*(q->done)) {
        DUMP1("processed by another event-loop");
        return 0;
    } else {
        DUMP1("process it on current event-loop");
    }

    if (RTEST(rb_thread_alive_p(thread))
	&& ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
      DUMP1("caller is not yet ready to receive the result -> pending");
      return 0;
    }

    /* process it */
    *(q->done) = 1;

    /* deleted ipterp ? */
    ptr = get_ip(q->interp);
    if (deleted_ip(ptr)) {
        /* deleted IP --> ignore */
        return 1;
    }

    /* incr internal handler mark */
    rbtk_internal_eventloop_handler++;

    /* check safe-level */
    if (rb_safe_level() != q->safe_level) {
        /* q_dat = Data_Wrap_Struct(rb_cData,0,0,q); */
        q_dat = Data_Wrap_Struct(0,invoke_queue_mark,-1,q);
        ret = rb_funcall(rb_proc_new(ivq_safelevel_handler, q_dat),
                         ID_call, 0);
        rb_gc_force_recycle(q_dat);
	q_dat = (VALUE)NULL;
    } else {
        DUMP2("call invoke_real (for caller thread:%"PRIxVALUE")", thread);
        DUMP2("call invoke_real (current thread:%"PRIxVALUE")", rb_thread_current());
        ret = ip_invoke_core(q->interp, q->argc, q->argv);
    }

    /* set result */
    RARRAY_PTR(q->result)[0] = ret;
    ret = (VALUE)NULL;

    /* decr internal handler mark */
    rbtk_internal_eventloop_handler--;

    /* complete */
    *(q->done) = -1;

    /* unlink ruby objects */
    q->interp = (VALUE)NULL;
    q->result = (VALUE)NULL;
    q->thread = (VALUE)NULL;

    /* back to caller */
    if (RTEST(rb_thread_alive_p(thread))) {
      DUMP2("back to caller (caller thread:%"PRIxVALUE")", thread);
      DUMP2("               (current thread:%"PRIxVALUE")", rb_thread_current());
#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
      have_rb_thread_waiting_for_value = 1;
      rb_thread_wakeup(thread);
#else
      rb_thread_run(thread);
#endif
      DUMP1("finish back to caller");
#if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE
      rb_thread_schedule();
#endif
    } else {
      DUMP2("caller is dead (caller thread:%"PRIxVALUE")", thread);
      DUMP2("               (current thread:%"PRIxVALUE")", rb_thread_current());
    }

    /* end of handler : remove it */
    return 1;
}

Project: tk
File: tcltklib.c

ip_eval(self, str)
    VALUE self;
    VALUE str;
{
    struct eval_queue *evq;
#ifdef RUBY_USE_NATIVE_THREAD
    struct tcltkip *ptr;
#endif
    char *eval_str;
    int  *alloc_done;
    int  thr_crit_bup;
    volatile VALUE current = rb_thread_current();
    volatile VALUE ip_obj = self;
    volatile VALUE result;
    volatile VALUE ret;
    Tcl_QueuePosition position;
    struct timeval t;

    thr_crit_bup = rb_thread_critical;
    rb_thread_critical = Qtrue;
    StringValue(str);
    rb_thread_critical = thr_crit_bup;

#ifdef RUBY_USE_NATIVE_THREAD
    ptr = get_ip(ip_obj);
    DUMP2("eval status: ptr->tk_thread_id %p", ptr->tk_thread_id);
    DUMP2("eval status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
#else
    DUMP2("status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
#endif
    DUMP2("status: eventloopt_thread %"PRIxVALUE, eventloop_thread);

    if (
#ifdef RUBY_USE_NATIVE_THREAD
	(ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread())
	&&
#endif
	(NIL_P(eventloop_thread) || current == eventloop_thread)
	) {
        if (NIL_P(eventloop_thread)) {
            DUMP2("eval from thread:%"PRIxVALUE" but no eventloop", current);
        } else {
            DUMP2("eval from current eventloop %"PRIxVALUE, current);
        }
        result = ip_eval_real(self, RSTRING_PTR(str), RSTRING_LENINT(str));
        if (rb_obj_is_kind_of(result, rb_eException)) {
            rb_exc_raise(result);
        }
        return result;
    }

    DUMP2("eval from thread %"PRIxVALUE" (NOT current eventloop)", current);

    thr_crit_bup = rb_thread_critical;
    rb_thread_critical = Qtrue;

    /* allocate memory (keep result) */
    /* alloc_done = (int*)ALLOC(int); */
    alloc_done = RbTk_ALLOC_N(int, 1);
#if 0 /* use Tcl_Preserve/Release */
    Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */
#endif
    *alloc_done = 0;

    /* eval_str = ALLOC_N(char, RSTRING_LEN(str) + 1); */
    eval_str = ckalloc(RSTRING_LENINT(str) + 1);
#if 0 /* use Tcl_Preserve/Release */
    Tcl_Preserve((ClientData)eval_str); /* XXXXXXXX */
#endif
    memcpy(eval_str, RSTRING_PTR(str), RSTRING_LEN(str));
    eval_str[RSTRING_LEN(str)] = 0;

    /* allocate memory (freed by Tcl_ServiceEvent) */
    /* evq = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue)); */
    evq = RbTk_ALLOC_N(struct eval_queue, 1);
#if 0 /* use Tcl_Preserve/Release */
    Tcl_Preserve(evq);
#endif

    /* allocate result obj */
    result = rb_ary_new3(1, Qnil);

    /* construct event data */
    evq->done = alloc_done;
    evq->str = eval_str;
    evq->len = RSTRING_LENINT(str);
    evq->interp = ip_obj;
    evq->result = result;
    evq->thread = current;
    evq->safe_level = rb_safe_level();
    evq->ev.proc = eval_queue_handler;

    position = TCL_QUEUE_TAIL;

    /* add the handler to Tcl event queue */
    DUMP1("add handler");
#ifdef RUBY_USE_NATIVE_THREAD
    if (ptr->tk_thread_id) {
      /* Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(evq->ev), position); */
      Tcl_ThreadQueueEvent(ptr->tk_thread_id, (Tcl_Event*)evq, position);
      Tcl_ThreadAlert(ptr->tk_thread_id);
    } else if (tk_eventloop_thread_id) {
      Tcl_ThreadQueueEvent(tk_eventloop_thread_id, (Tcl_Event*)evq, position);
      /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
			   &(evq->ev), position); */
      Tcl_ThreadAlert(tk_eventloop_thread_id);
    } else {
      /* Tcl_QueueEvent(&(evq->ev), position); */
      Tcl_QueueEvent((Tcl_Event*)evq, position);
    }
#else
    /* Tcl_QueueEvent(&(evq->ev), position); */
    Tcl_QueueEvent((Tcl_Event*)evq, position);
#endif

    rb_thread_critical = thr_crit_bup;

    /* wait for the handler to be processed */
    t.tv_sec  = 0;
    t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);

    DUMP2("evq wait for handler (current thread:%"PRIxVALUE")", current);
    while(*alloc_done >= 0) {
      DUMP2("*** evq wait for handler (current thread:%"PRIxVALUE")", current);
      /* rb_thread_stop(); */
      /* rb_thread_sleep_forever(); */
      rb_thread_wait_for(t);
      DUMP2("*** evq wakeup (current thread:%"PRIxVALUE")", current);
      DUMP2("***          (eventloop thread:%"PRIxVALUE")", eventloop_thread);
      if (NIL_P(eventloop_thread)) {
	DUMP1("*** evq lost eventloop thread");
	break;
      }
    }
    DUMP2("back from handler (current thread:%"PRIxVALUE")", current);

    /* get result & free allocated memory */
    ret = RARRAY_PTR(result)[0];

#if 0 /* use Tcl_EventuallyFree */
    Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
    Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */
#else
    /* free(alloc_done); */
    ckfree((char*)alloc_done);
#endif
#endif
#if 0 /* use Tcl_EventuallyFree */
    Tcl_EventuallyFree((ClientData)eval_str, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
    Tcl_Release((ClientData)eval_str); /* XXXXXXXX */
#else
    /* free(eval_str); */
    ckfree(eval_str);
#endif
#endif
#if 0 /* evq is freed by Tcl_ServiceEvent */
#if 0 /* use Tcl_Preserve/Release */
    Tcl_Release(evq);
#else
    ckfree((char*)evq);
#endif
#endif

    if (rb_obj_is_kind_of(ret, rb_eException)) {
        DUMP1("raise exception");
        /* rb_exc_raise(ret); */
	rb_exc_raise(rb_exc_new3(rb_obj_class(ret),
				 rb_funcallv(ret, ID_to_s, 0, 0)));
    }

    return ret;
}

Project: tk
File: tcltklib.c

call_queue_handler(evPtr, flags)
    Tcl_Event *evPtr;
    int flags;
{
    struct call_queue *q = (struct call_queue *)evPtr;
    volatile VALUE ret;
    volatile VALUE q_dat;
    volatile VALUE thread = q->thread;
    struct tcltkip *ptr;

    DUMP2("do_call_queue_handler : evPtr = %p", evPtr);
    DUMP2("call_queue_handler thread : %"PRIxVALUE, rb_thread_current());
    DUMP2("added by thread : %"PRIxVALUE, thread);

    if (*(q->done)) {
        DUMP1("processed by another event-loop");
        return 0;
    } else {
        DUMP1("process it on current event-loop");
    }

    if (RTEST(rb_thread_alive_p(thread))
	&& ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
      DUMP1("caller is not yet ready to receive the result -> pending");
      return 0;
    }

    /* process it */
    *(q->done) = 1;

    /* deleted ipterp ? */
    ptr = get_ip(q->interp);
    if (deleted_ip(ptr)) {
        /* deleted IP --> ignore */
        return 1;
    }

    /* incr internal handler mark */
    rbtk_internal_eventloop_handler++;

    /* check safe-level */
    if (rb_safe_level() != q->safe_level) {
        /* q_dat = Data_Wrap_Struct(rb_cData,0,-1,q); */
        q_dat = Data_Wrap_Struct(0,call_queue_mark,-1,q);
        ret = rb_funcall(rb_proc_new(callq_safelevel_handler, q_dat),
                         ID_call, 0);
        rb_gc_force_recycle(q_dat);
	q_dat = (VALUE)NULL;
    } else {
        DUMP2("call function (for caller thread:%"PRIxVALUE")", thread);
        DUMP2("call function (current thread:%"PRIxVALUE")", rb_thread_current());
        ret = (q->func)(q->interp, q->argc, q->argv);
    }

    /* set result */
    RARRAY_PTR(q->result)[0] = ret;
    ret = (VALUE)NULL;

    /* decr internal handler mark */
    rbtk_internal_eventloop_handler--;

    /* complete */
    *(q->done) = -1;

    /* unlink ruby objects */
    q->argv = (VALUE*)NULL;
    q->interp = (VALUE)NULL;
    q->result = (VALUE)NULL;
    q->thread = (VALUE)NULL;

    /* back to caller */
    if (RTEST(rb_thread_alive_p(thread))) {
      DUMP2("back to caller (caller thread:%"PRIxVALUE")", thread);
      DUMP2("               (current thread:%"PRIxVALUE")", rb_thread_current());
#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
      have_rb_thread_waiting_for_value = 1;
      rb_thread_wakeup(thread);
#else
      rb_thread_run(thread);
#endif
      DUMP1("finish back to caller");
#if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE
      rb_thread_schedule();
#endif
    } else {
      DUMP2("caller is dead (caller thread:%"PRIxVALUE")", thread);
      DUMP2("               (current thread:%"PRIxVALUE")", rb_thread_current());
    }

    /* end of handler : remove it */
    return 1;
}

Project: tk
File: tcltklib.c

eval_queue_handler(evPtr, flags)
    Tcl_Event *evPtr;
    int flags;
{
    struct eval_queue *q = (struct eval_queue *)evPtr;
    volatile VALUE ret;
    volatile VALUE q_dat;
    volatile VALUE thread = q->thread;
    struct tcltkip *ptr;

    DUMP2("do_eval_queue_handler : evPtr = %p", evPtr);
    DUMP2("eval_queue_thread : %"PRIxVALUE, rb_thread_current());
    DUMP2("added by thread : %"PRIxVALUE, thread);

    if (*(q->done)) {
        DUMP1("processed by another event-loop");
        return 0;
    } else {
        DUMP1("process it on current event-loop");
    }

    if (RTEST(rb_thread_alive_p(thread))
	&& ! RTEST(rb_funcall(thread, ID_stop_p, 0))) {
      DUMP1("caller is not yet ready to receive the result -> pending");
      return 0;
    }

    /* process it */
    *(q->done) = 1;

    /* deleted ipterp ? */
    ptr = get_ip(q->interp);
    if (deleted_ip(ptr)) {
        /* deleted IP --> ignore */
        return 1;
    }

    /* incr internal handler mark */
    rbtk_internal_eventloop_handler++;

    /* check safe-level */
    if (rb_safe_level() != q->safe_level) {
#ifdef HAVE_NATIVETHREAD
#ifndef RUBY_USE_NATIVE_THREAD
    if (!ruby_native_thread_p()) {
      rb_bug("cross-thread violation on eval_queue_handler()");
    }
#endif
#endif
        /* q_dat = Data_Wrap_Struct(rb_cData,0,-1,q); */
        q_dat = Data_Wrap_Struct(0,eval_queue_mark,-1,q);
        ret = rb_funcall(rb_proc_new(evq_safelevel_handler, q_dat),
                         ID_call, 0);
        rb_gc_force_recycle(q_dat);
	q_dat = (VALUE)NULL;
    } else {
        ret = ip_eval_real(q->interp, q->str, q->len);
    }

    /* set result */
    RARRAY_PTR(q->result)[0] = ret;
    ret = (VALUE)NULL;

    /* decr internal handler mark */
    rbtk_internal_eventloop_handler--;

    /* complete */
    *(q->done) = -1;

    /* unlink ruby objects */
    q->interp = (VALUE)NULL;
    q->result = (VALUE)NULL;
    q->thread = (VALUE)NULL;

    /* back to caller */
    if (RTEST(rb_thread_alive_p(thread))) {
      DUMP2("back to caller (caller thread:%"PRIxVALUE")", thread);
      DUMP2("               (current thread:%"PRIxVALUE")", rb_thread_current());
#if CONTROL_BY_STATUS_OF_RB_THREAD_WAITING_FOR_VALUE
      have_rb_thread_waiting_for_value = 1;
      rb_thread_wakeup(thread);
#else
      rb_thread_run(thread);
#endif
      DUMP1("finish back to caller");
#if DO_THREAD_SCHEDULE_AT_CALLBACK_DONE
      rb_thread_schedule();
#endif
    } else {
      DUMP2("caller is dead (caller thread:%"PRIxVALUE")", thread);
      DUMP2("               (current thread:%"PRIxVALUE")", rb_thread_current());
    }

    /* end of handler : remove it */
    return 1;
}

Project: tk
File: tcltklib.c

ip_ruby_cmd(clientData, interp, argc, argv)
    ClientData clientData;
    Tcl_Interp *interp;
    int argc;
    char *argv[];
#endif
{
    volatile VALUE receiver;
    volatile ID method;
    volatile VALUE args;
    char *str;
    int i;
    int  len;
    struct cmd_body_arg *arg;
    int thr_crit_bup;
    VALUE old_gc;
    int code;

    if (interp == (Tcl_Interp*)NULL) {
        rbtk_pending_exception = rb_exc_new2(rb_eRuntimeError,
                                             "IP is deleted");
        return TCL_ERROR;
    }

    if (argc < 3) {
#if 0
        rb_raise(rb_eArgError, "too few arguments");
#else
        Tcl_ResetResult(interp);
        Tcl_AppendResult(interp, "too few arguments", (char *)NULL);
        rbtk_pending_exception = rb_exc_new2(rb_eArgError,
                                             Tcl_GetStringResult(interp));
        return TCL_ERROR;
#endif
    }

    /* get arguments from Tcl objects */
    thr_crit_bup = rb_thread_critical;
    rb_thread_critical = Qtrue;
    old_gc = rb_gc_disable();

    /* get receiver */
#if TCL_MAJOR_VERSION >= 8
    str = Tcl_GetStringFromObj(argv[1], &len);
#else /* TCL_MAJOR_VERSION < 8 */
    str = argv[1];
#endif
    DUMP2("receiver:%s",str);
    /* receiver = rb_protect(ip_ruby_cmd_receiver_get, (VALUE)str, &code); */
    receiver = ip_ruby_cmd_receiver_get(str);
    if (NIL_P(receiver)) {
#if 0
        rb_raise(rb_eArgError,
                 "unknown class/module/global-variable '%s'", str);
#else
        Tcl_ResetResult(interp);
        Tcl_AppendResult(interp, "unknown class/module/global-variable '",
                         str, "'", (char *)NULL);
        rbtk_pending_exception = rb_exc_new2(rb_eArgError,
                                             Tcl_GetStringResult(interp));
        if (old_gc == Qfalse) rb_gc_enable();
        return TCL_ERROR;
#endif
    }

    /* get metrhod */
#if TCL_MAJOR_VERSION >= 8
    str = Tcl_GetStringFromObj(argv[2], &len);
#else /* TCL_MAJOR_VERSION < 8 */
    str = argv[2];
#endif
    method = rb_intern(str);

    /* get args */
    args = rb_ary_new2(argc - 2);
    for(i = 3; i < argc; i++) {
        VALUE s;
#if TCL_MAJOR_VERSION >= 8
        str = Tcl_GetStringFromObj(argv[i], &len);
        s = rb_tainted_str_new(str, len);
#else /* TCL_MAJOR_VERSION < 8 */
        str = argv[i];
        s = rb_tainted_str_new2(str);
#endif
        DUMP2("arg:%s",str);
#ifndef HAVE_STRUCT_RARRAY_LEN
        rb_ary_push(args, s);
#else
        RARRAY(args)->ptr[RARRAY(args)->len++] = s;
#endif
    }

    if (old_gc == Qfalse) rb_gc_enable();
    rb_thread_critical = thr_crit_bup;

    /* allocate */
    arg = ALLOC(struct cmd_body_arg);
    /* arg = RbTk_ALLOC_N(struct cmd_body_arg, 1); */

    arg->receiver = receiver;
    arg->method = method;
    arg->args = args;

    /* evaluate the argument string by ruby */
    code = tcl_protect(interp, ip_ruby_cmd_core, (VALUE)arg);

    xfree(arg);
    /* ckfree((char*)arg); */

    return code;
}

Project: tk
File: tcltklib.c

ip_RubyExitCommand(clientData, interp, argc, argv)
    ClientData clientData;
    Tcl_Interp *interp;
    int argc;
    char *argv[];
#endif
#endif
{
    int state;
    char *cmd, *param;
#if TCL_MAJOR_VERSION < 8
    char *endptr;
    cmd = argv[0];
#endif

    DUMP1("start ip_RubyExitCommand");

#if TCL_MAJOR_VERSION >= 8
    /* cmd = Tcl_GetString(argv[0]); */
    cmd = Tcl_GetStringFromObj(argv[0], (int*)NULL);
#endif

    if (argc < 1 || argc > 2) {
        /* argument error */
        Tcl_AppendResult(interp,
                         "wrong number of arguments: should be \"",
                         cmd, " ?returnCode?\"", (char *)NULL);
        return TCL_ERROR;
    }

    if (interp == (Tcl_Interp*)NULL) return TCL_OK;

    Tcl_ResetResult(interp);

    if (Tcl_IsSafe(interp)) {
	if (!Tcl_InterpDeleted(interp)) {
	  ip_finalize(interp);

	  Tcl_DeleteInterp(interp);
	  Tcl_Release(interp);
	}
        return TCL_OK;
    }

    switch(argc) {
    case 1:
        /* rb_exit(0); */ /* not return if succeed */
        Tcl_AppendResult(interp,
                         "fail to call \"", cmd, "\"", (char *)NULL);

        rbtk_pending_exception = rb_exc_new2(rb_eSystemExit,
                                             Tcl_GetStringResult(interp));
        rb_iv_set(rbtk_pending_exception, "status", INT2FIX(0));

        return TCL_RETURN;

    case 2:
#if TCL_MAJOR_VERSION >= 8
        if (Tcl_GetIntFromObj(interp, argv[1], &state) == TCL_ERROR) {
            return TCL_ERROR;
        }
        /* param = Tcl_GetString(argv[1]); */
        param = Tcl_GetStringFromObj(argv[1], (int*)NULL);
#else /* TCL_MAJOR_VERSION < 8 */
        state = (int)strtol(argv[1], &endptr, 0);
        if (*endptr) {
            Tcl_AppendResult(interp,
                             "expected integer but got \"",
                             argv[1], "\"", (char *)NULL);
            return TCL_ERROR;
        }
        param = argv[1];
#endif
        /* rb_exit(state); */ /* not return if succeed */

        Tcl_AppendResult(interp, "fail to call \"", cmd, " ",
                         param, "\"", (char *)NULL);

        rbtk_pending_exception = rb_exc_new2(rb_eSystemExit,
                                             Tcl_GetStringResult(interp));
        rb_iv_set(rbtk_pending_exception, "status", INT2FIX(state));

        return TCL_RETURN;

    default:
        /* arguemnt error */
        Tcl_AppendResult(interp,
                         "wrong number of arguments: should be \"",
                         cmd, " ?returnCode?\"", (char *)NULL);
        return TCL_ERROR;
    }
}

Project: tk
File: tcltklib.c

ip_invoke_with_position(argc, argv, obj, position)
    int argc;
    VALUE *argv;
    VALUE obj;
    Tcl_QueuePosition position;
{
    struct invoke_queue *ivq;
#ifdef RUBY_USE_NATIVE_THREAD
    struct tcltkip *ptr;
#endif
    int  *alloc_done;
    int  thr_crit_bup;
    volatile VALUE current = rb_thread_current();
    volatile VALUE ip_obj = obj;
    volatile VALUE result;
    volatile VALUE ret;
    struct timeval t;

#if TCL_MAJOR_VERSION >= 8
    Tcl_Obj **av = (Tcl_Obj **)NULL;
#else /* TCL_MAJOR_VERSION < 8 */
    char **av = (char **)NULL;
#endif

    if (argc < 1) {
        rb_raise(rb_eArgError, "command name missing");
    }

#ifdef RUBY_USE_NATIVE_THREAD
    ptr = get_ip(ip_obj);
    DUMP2("invoke status: ptr->tk_thread_id %p", ptr->tk_thread_id);
    DUMP2("invoke status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
#else
    DUMP2("status: Tcl_GetCurrentThread %p", Tcl_GetCurrentThread());
#endif
    DUMP2("status: eventloopt_thread %"PRIxVALUE, eventloop_thread);

    if (
#ifdef RUBY_USE_NATIVE_THREAD
	(ptr->tk_thread_id == 0 || ptr->tk_thread_id == Tcl_GetCurrentThread())
	&&
#endif
	(NIL_P(eventloop_thread) || current == eventloop_thread)
	) {
        if (NIL_P(eventloop_thread)) {
            DUMP2("invoke from thread:%"PRIxVALUE" but no eventloop", current);
        } else {
            DUMP2("invoke from current eventloop %"PRIxVALUE, current);
        }
        result = ip_invoke_real(argc, argv, ip_obj);
        if (rb_obj_is_kind_of(result, rb_eException)) {
            rb_exc_raise(result);
        }
        return result;
    }

    DUMP2("invoke from thread %"PRIxVALUE" (NOT current eventloop)", current);

    thr_crit_bup = rb_thread_critical;
    rb_thread_critical = Qtrue;

    /* allocate memory (for arguments) */
    av = alloc_invoke_arguments(argc, argv);

    /* allocate memory (keep result) */
    /* alloc_done = (int*)ALLOC(int); */
    alloc_done = RbTk_ALLOC_N(int, 1);
#if 0 /* use Tcl_Preserve/Release */
    Tcl_Preserve((ClientData)alloc_done); /* XXXXXXXX */
#endif
    *alloc_done = 0;

    /* allocate memory (freed by Tcl_ServiceEvent) */
    /* ivq = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue)); */
    ivq = RbTk_ALLOC_N(struct invoke_queue, 1);
#if 0 /* use Tcl_Preserve/Release */
    Tcl_Preserve((ClientData)ivq); /* XXXXXXXX */
#endif

    /* allocate result obj */
    result = rb_ary_new3(1, Qnil);

    /* construct event data */
    ivq->done = alloc_done;
    ivq->argc = argc;
    ivq->argv = av;
    ivq->interp = ip_obj;
    ivq->result = result;
    ivq->thread = current;
    ivq->safe_level = rb_safe_level();
    ivq->ev.proc = invoke_queue_handler;

    /* add the handler to Tcl event queue */
    DUMP1("add handler");
#ifdef RUBY_USE_NATIVE_THREAD
    if (ptr->tk_thread_id) {
      /* Tcl_ThreadQueueEvent(ptr->tk_thread_id, &(ivq->ev), position); */
      Tcl_ThreadQueueEvent(ptr->tk_thread_id, (Tcl_Event*)ivq, position);
      Tcl_ThreadAlert(ptr->tk_thread_id);
    } else if (tk_eventloop_thread_id) {
      /* Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
			   &(ivq->ev), position); */
      Tcl_ThreadQueueEvent(tk_eventloop_thread_id,
			   (Tcl_Event*)ivq, position);
      Tcl_ThreadAlert(tk_eventloop_thread_id);
    } else {
      /* Tcl_QueueEvent(&(ivq->ev), position); */
      Tcl_QueueEvent((Tcl_Event*)ivq, position);
    }
#else
    /* Tcl_QueueEvent(&(ivq->ev), position); */
    Tcl_QueueEvent((Tcl_Event*)ivq, position);
#endif

    rb_thread_critical = thr_crit_bup;

    /* wait for the handler to be processed */
    t.tv_sec  = 0;
    t.tv_usec = (long)((EVENT_HANDLER_TIMEOUT)*1000.0);

    DUMP2("ivq wait for handler (current thread:%"PRIxVALUE")", current);
    while(*alloc_done >= 0) {
      /* rb_thread_stop(); */
      /* rb_thread_sleep_forever(); */
      rb_thread_wait_for(t);
      DUMP2("*** ivq wakeup (current thread:%"PRIxVALUE")", current);
      DUMP2("***          (eventloop thread:%"PRIxVALUE")", eventloop_thread);
      if (NIL_P(eventloop_thread)) {
	DUMP1("*** ivq lost eventloop thread");
	break;
      }
    }
    DUMP2("back from handler (current thread:%"PRIxVALUE")", current);

    /* get result & free allocated memory */
    ret = RARRAY_PTR(result)[0];
#if 0 /* use Tcl_EventuallyFree */
    Tcl_EventuallyFree((ClientData)alloc_done, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
    Tcl_Release((ClientData)alloc_done); /* XXXXXXXX */
#else
    /* free(alloc_done); */
    ckfree((char*)alloc_done);
#endif
#endif

#if 0 /* ivq is freed by Tcl_ServiceEvent */
#if 0 /* use Tcl_EventuallyFree */
    Tcl_EventuallyFree((ClientData)ivq, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
    Tcl_Release(ivq);
#else
    ckfree((char*)ivq);
#endif
#endif
#endif

    /* free allocated memory */
    free_invoke_arguments(argc, av);

    /* exception? */
    if (rb_obj_is_kind_of(ret, rb_eException)) {
        DUMP1("raise exception");
        /* rb_exc_raise(ret); */
	rb_exc_raise(rb_exc_new3(rb_obj_class(ret),
				 rb_funcallv(ret, ID_to_s, 0, 0)));
    }

    DUMP1("exit ip_invoke");
    return ret;
}

Project: tk
File: tcltklib.c

tcltklib_compile_info(void)
{
    volatile VALUE ret;
    size_t size;
    static CONST char form[]
      = "tcltklib %s :: Ruby%s (%s) %s pthread :: Tcl%s(%s)/Tk%s(%s) %s";
    char *info;

    size = strlen(form)
        + strlen(TCLTKLIB_RELEASE_DATE)
        + strlen(RUBY_VERSION)
        + strlen(RUBY_RELEASE_DATE)
        + strlen("without")
        + strlen(TCL_PATCH_LEVEL)
        + strlen("without stub")
        + strlen(TK_PATCH_LEVEL)
        + strlen("without stub")
        + strlen("unknown tcl_threads");

    info = ALLOC_N(char, size);
    /* info = ckalloc(sizeof(char) * size); */ /* SEGV */

    sprintf(info, form,
            TCLTKLIB_RELEASE_DATE,
            RUBY_VERSION, RUBY_RELEASE_DATE,
#ifdef HAVE_NATIVETHREAD
            "with",
#else
            "without",
#endif
            TCL_PATCH_LEVEL,
#ifdef USE_TCL_STUBS
            "with stub",
#else
            "without stub",
#endif
            TK_PATCH_LEVEL,
#ifdef USE_TK_STUBS
            "with stub",
#else
            "without stub",
#endif
#ifdef WITH_TCL_ENABLE_THREAD
# if WITH_TCL_ENABLE_THREAD
            "with tcl_threads"
# else
            "without tcl_threads"
# endif
#else
            "unknown tcl_threads"
#endif
        );

    ret = rb_obj_freeze(rb_str_new2(info));

    xfree(info);
    /* ckfree(info); */

    return ret;
}

Project: tk
File: tcltklib.c

ip_invoke_core(interp, argc, argv)
    VALUE interp;
    int argc;
    char **argv;
#endif
{
    struct tcltkip *ptr;
    Tcl_CmdInfo info;
    char *cmd;
    int  len;
    int  thr_crit_bup;
    int unknown_flag = 0;

#if 1 /* wrap tcl-proc call */
    struct invoke_info inf;
    int status;
#else
#if TCL_MAJOR_VERSION >= 8
    int argc = objc;
    char **argv = (char **)NULL;
    /* Tcl_Obj *resultPtr; */
#endif
#endif

    /* get the command name string */
#if TCL_MAJOR_VERSION >= 8
    cmd = Tcl_GetStringFromObj(objv[0], &len);
#else /* TCL_MAJOR_VERSION < 8 */
    cmd = argv[0];
#endif

    /* get the data struct */
    ptr = get_ip(interp);

    /* ip is deleted? */
    if (deleted_ip(ptr)) {
        return rb_tainted_str_new2("");
    }

    /* Tcl_Preserve(ptr->ip); */
    rbtk_preserve_ip(ptr);

    /* map from the command name to a C procedure */
    DUMP2("call Tcl_GetCommandInfo, %s", cmd);
    if (!Tcl_GetCommandInfo(ptr->ip, cmd, &info)) {
        DUMP1("error Tcl_GetCommandInfo");
        DUMP1("try auto_load (call 'unknown' command)");
        if (!Tcl_GetCommandInfo(ptr->ip,
#if TCL_MAJOR_VERSION >= 8
                                "::unknown",
#else
                                "unknown",
#endif
                                &info)) {
            DUMP1("fail to get 'unknown' command");
            /* if (event_loop_abort_on_exc || cmd[0] != '.') { */
            if (event_loop_abort_on_exc > 0) {
                /* Tcl_Release(ptr->ip); */
                rbtk_release_ip(ptr);
                /*rb_ip_raise(obj,rb_eNameError,"invalid command name `%s'",cmd);*/
                return create_ip_exc(interp, rb_eNameError,
                                     "invalid command name `%s'", cmd);
            } else {
                if (event_loop_abort_on_exc < 0) {
                    rb_warning("invalid command name `%s' (ignore)", cmd);
                } else {
                    rb_warn("invalid command name `%s' (ignore)", cmd);
                }
                Tcl_ResetResult(ptr->ip);
                /* Tcl_Release(ptr->ip); */
                rbtk_release_ip(ptr);
                return rb_tainted_str_new2("");
            }
        } else {
#if TCL_MAJOR_VERSION >= 8
            Tcl_Obj **unknown_objv;
#else
            char **unknown_argv;
#endif
            DUMP1("find 'unknown' command -> set arguemnts");
            unknown_flag = 1;

#if TCL_MAJOR_VERSION >= 8
            /* unknown_objv = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, objc+2); */
            unknown_objv = RbTk_ALLOC_N(Tcl_Obj *, (objc+2));
#if 0 /* use Tcl_Preserve/Release */
	    Tcl_Preserve((ClientData)unknown_objv); /* XXXXXXXX */
#endif
            unknown_objv[0] = Tcl_NewStringObj("::unknown", 9);
            Tcl_IncrRefCount(unknown_objv[0]);
            memcpy(unknown_objv + 1, objv, sizeof(Tcl_Obj *)*objc);
            unknown_objv[++objc] = (Tcl_Obj*)NULL;
            objv = unknown_objv;
#else
            /* unknown_argv = (char **)ALLOC_N(char *, argc+2); */
            unknown_argv = RbTk_ALLOC_N(char *, (argc+2));
#if 0 /* use Tcl_Preserve/Release */
	    Tcl_Preserve((ClientData)unknown_argv); /* XXXXXXXX */
#endif
            unknown_argv[0] = strdup("unknown");
            memcpy(unknown_argv + 1, argv, sizeof(char *)*argc);
            unknown_argv[++argc] = (char *)NULL;
            argv = unknown_argv;
#endif
        }
    }
    DUMP1("end Tcl_GetCommandInfo");

    thr_crit_bup = rb_thread_critical;
    rb_thread_critical = Qtrue;

#if 1 /* wrap tcl-proc call */
    /* setup params */
    inf.ptr = ptr;
    inf.cmdinfo = info;
#if TCL_MAJOR_VERSION >= 8
    inf.objc = objc;
    inf.objv = objv;
#else
    inf.argc = argc;
    inf.argv = argv;
#endif

    /* invoke tcl-proc */
    DUMP1("invoke tcl-proc");
    rb_protect(invoke_tcl_proc, (VALUE)&inf, &status);
    DUMP2("status of tcl-proc, %d", status);
    switch(status) {
    case TAG_RAISE:
        if (NIL_P(rb_errinfo())) {
            rbtk_pending_exception = rb_exc_new2(rb_eException,
                                                 "unknown exception");
        } else {
            rbtk_pending_exception = rb_errinfo();
        }
        break;

    case TAG_FATAL:
        if (NIL_P(rb_errinfo())) {
            rbtk_pending_exception = rb_exc_new2(rb_eFatal, "FATAL");
        } else {
            rbtk_pending_exception = rb_errinfo();
        }
    }

#else /* !wrap tcl-proc call */

    /* memory allocation for arguments of this command */
#if TCL_MAJOR_VERSION >= 8
    if (!info.isNativeObjectProc) {
        int i;

        /* string interface */
        /* argv = (char **)ALLOC_N(char *, argc+1); */
        argv = RbTk_ALLOC_N(char *, (argc+1));
#if 0 /* use Tcl_Preserve/Release */
	Tcl_Preserve((ClientData)argv); /* XXXXXXXX */
#endif
        for (i = 0; i < argc; ++i) {
            argv[i] = Tcl_GetStringFromObj(objv[i], &len);
        }
        argv[argc] = (char *)NULL;
    }
#endif

    Tcl_ResetResult(ptr->ip);

    /* Invoke the C procedure */
#if TCL_MAJOR_VERSION >= 8
    if (info.isNativeObjectProc) {
        ptr->return_value = (*info.objProc)(info.objClientData, ptr->ip,
                                            objc, objv);
#if 0
        /* get the string value from the result object */
        resultPtr = Tcl_GetObjResult(ptr->ip);
        Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &len),
                      TCL_VOLATILE);
#endif
    }
    else
#endif
    {
#if TCL_MAJOR_VERSION >= 8
        ptr->return_value = (*info.proc)(info.clientData, ptr->ip,
                                         argc, (CONST84 char **)argv);

#if 0 /* use Tcl_EventuallyFree */
    Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
	Tcl_Release((ClientData)argv); /* XXXXXXXX */
#else
        /* free(argv); */
        ckfree((char*)argv);
#endif
#endif

#else /* TCL_MAJOR_VERSION < 8 */
        ptr->return_value = (*info.proc)(info.clientData, ptr->ip,
                                         argc, argv);
#endif
    }
#endif /* ! wrap tcl-proc call */

    /* free allocated memory for calling 'unknown' command */
    if (unknown_flag) {
#if TCL_MAJOR_VERSION >= 8
        Tcl_DecrRefCount(objv[0]);
#if 0 /* use Tcl_EventuallyFree */
	Tcl_EventuallyFree((ClientData)objv, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
	Tcl_Release((ClientData)objv); /* XXXXXXXX */
#else
        /* free(objv); */
        ckfree((char*)objv);
#endif
#endif
#else /* TCL_MAJOR_VERSION < 8 */
        free(argv[0]);
        /* ckfree(argv[0]); */
#if 0 /* use Tcl_EventuallyFree */
	Tcl_EventuallyFree((ClientData)argv, TCL_DYNAMIC); /* XXXXXXXX */
#else
#if 0 /* use Tcl_Preserve/Release */
	Tcl_Release((ClientData)argv); /* XXXXXXXX */
#else
        /* free(argv); */
        ckfree((char*)argv);
#endif
#endif
#endif
    }

    /* exception on mainloop */
    if (pending_exception_check1(thr_crit_bup, ptr)) {
        return rbtk_pending_exception;
    }

    rb_thread_critical = thr_crit_bup;

    /* if (ptr->return_value == TCL_ERROR) { */
    if (ptr->return_value != TCL_OK) {
        if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) {
	    switch (ptr->return_value) {
	    case TCL_RETURN:
	      return create_ip_exc(interp, eTkCallbackReturn,
				   "ip_invoke_core receives TCL_RETURN");
	    case TCL_BREAK:
	      return create_ip_exc(interp, eTkCallbackBreak,
				   "ip_invoke_core receives TCL_BREAK");
	    case TCL_CONTINUE:
	      return create_ip_exc(interp, eTkCallbackContinue,
				   "ip_invoke_core receives TCL_CONTINUE");
	    default:
	      return create_ip_exc(interp, rb_eRuntimeError, "%s",
				   Tcl_GetStringResult(ptr->ip));
	    }

        } else {
            if (event_loop_abort_on_exc < 0) {
                rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip));
            } else {
                rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip));
            }
            Tcl_ResetResult(ptr->ip);
            return rb_tainted_str_new2("");
        }
    }

    /* pass back the result (as string) */
    return ip_get_result_string_obj(ptr->ip);
}

Project: tk
File: tcltklib.c

lib_do_one_event_core(argc, argv, self, is_ip)
    int   argc;
    VALUE *argv;
    VALUE self;
    int   is_ip;
{
    volatile VALUE vflags;
    int flags;
    int found_event;

    if (!NIL_P(eventloop_thread)) {
        rb_raise(rb_eRuntimeError, "eventloop is already running");
    }

    tcl_stubs_check();

    if (rb_scan_args(argc, argv, "01", &vflags) == 0) {
        flags = TCL_ALL_EVENTS | TCL_DONT_WAIT;
    } else {
        Check_Type(vflags, T_FIXNUM);
        flags = FIX2INT(vflags);
    }

    if (rb_safe_level() >=1 && OBJ_TAINTED(vflags)) {
      flags |= TCL_DONT_WAIT;
    }

    if (is_ip) {
        /* check IP */
        struct tcltkip *ptr = get_ip(self);

        /* ip is deleted? */
        if (deleted_ip(ptr)) {
            return Qfalse;
        }

        if (Tcl_GetMaster(ptr->ip) != (Tcl_Interp*)NULL) {
            /* slave IP */
            flags |= TCL_DONT_WAIT;
        }
    }

    /* found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT); */
    found_event = Tcl_DoOneEvent(flags);

    if (pending_exception_check0()) {
        return Qfalse;
    }

    if (found_event) {
        return Qtrue;
    } else {
        return Qfalse;
    }
}