From 62e648e148b3cb9f96dcce808c55c02b7ccb4486 Mon Sep 17 00:00:00 2001 From: matz Date: Wed, 20 Jan 1999 04:59:39 +0000 Subject: ruby 1.3 cycle git-svn-id: svn+ssh://ci.ruby-lang.org/ruby/branches/RUBY@372 b2dd03c8-39d4-4d8f-98ff-823fe69b080e --- ext/tcltklib/tcltklib.c | 293 ++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 259 insertions(+), 34 deletions(-) (limited to 'ext/tcltklib/tcltklib.c') diff --git a/ext/tcltklib/tcltklib.c b/ext/tcltklib/tcltklib.c index e7fe77d2b7..625fe61ccc 100644 --- a/ext/tcltklib/tcltklib.c +++ b/ext/tcltklib/tcltklib.c @@ -5,22 +5,31 @@ */ #include "ruby.h" -#include "sig.h" +#include "rubysig.h" #include #include #include #include -/* for debug */ +#ifdef __MACOS__ +# include +# include +#endif -#define DUMP1(ARG1) if (debug) { fprintf(stderr, "tcltklib: %s\n", ARG1);} -#define DUMP2(ARG1, ARG2) if (debug) { fprintf(stderr, "tcltklib: ");\ +/* for rb_debug */ + +#define DUMP1(ARG1) if (rb_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1);} +#define DUMP2(ARG1, ARG2) if (rb_debug) { fprintf(stderr, "tcltklib: ");\ fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); } /* #define DUMP1(ARG1) #define DUMP2(ARG1, ARG2) */ +/* for callback break & continue */ +VALUE eTkCallbackBreak; +VALUE eTkCallbackContinue; + /* from tkAppInit.c */ /* @@ -33,26 +42,52 @@ int *tclDummyMathPtr = (int *) matherr; /*---- module TclTkLib ----*/ -static VALUE thread_safe = Qnil; +/* Tk_ThreadTimer */ +typedef struct { + Tcl_TimerToken token; + int flag; +} Tk_TimerData; + +/* timer callback */ +void _timer_for_tcl (ClientData clientData) +{ + Tk_TimerData *timer = (Tk_TimerData*)clientData; + + timer->flag = 0; + CHECK_INTS; +#ifdef USE_THREAD + if (!rb_thread_critical) rb_thread_schedule(); +#endif + + timer->token = Tk_CreateTimerHandler(200, _timer_for_tcl, + (ClientData)timer); + timer->flag = 1; +} /* execute Tk_MainLoop */ static VALUE lib_mainloop(VALUE self) { - int old_trapflg; - int flags = RTEST(thread_safe)?TCL_DONT_WAIT:0; + Tk_TimerData *timer; + + timer = (Tk_TimerData *) ckalloc(sizeof(Tk_TimerData)); + timer->flag = 0; + timer->token = Tk_CreateTimerHandler(200, _timer_for_tcl, + (ClientData)timer); + timer->flag = 1; DUMP1("start Tk_Mainloop"); while (Tk_GetNumMainWindows() > 0) { - old_trapflg = trap_immediate; - trap_immediate = 1; - Tcl_DoOneEvent(flags); - trap_immediate = old_trapflg; - CHECK_INTS; - flags = (thread_safe == 0 || thread_safe == Qnil)?0:TCL_DONT_WAIT; + Tcl_DoOneEvent(0); } DUMP1("stop Tk_Mainloop"); +#ifdef USE_THREAD + if (timer->flag) { + Tk_DeleteTimerHandler(timer->token); + } +#endif + return Qnil; } @@ -71,27 +106,49 @@ ip_eval_rescue(VALUE *failed, VALUE einfo) } static int +#if TCL_MAJOR_VERSION >= 8 +ip_ruby(ClientData clientData, Tcl_Interp *interp, + int argc, Tcl_Obj *CONST argv[]) +#else ip_ruby(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[]) +#endif { VALUE res; int old_trapflg; VALUE failed = 0; + char *arg; + int dummy; /* ruby command has 1 arg. */ if (argc != 2) { - ArgError("wrong # of arguments (%d for 1)", argc); + rb_raise(rb_eArgError, "wrong # of arguments (%d for 1)", argc); } + /* get C string from Tcl object */ +#if TCL_MAJOR_VERSION >= 8 + arg = Tcl_GetStringFromObj(argv[1], &dummy); +#else + arg = argv[1]; +#endif + /* evaluate the argument string by ruby */ - DUMP2("rb_eval_string(%s)", argv[1]); - old_trapflg = trap_immediate; - trap_immediate = 0; - res = rb_rescue(rb_eval_string, argv[1], ip_eval_rescue, &failed); - trap_immediate = old_trapflg; + DUMP2("rb_eval_string(%s)", arg); + old_trapflg = rb_trap_immediate; + rb_trap_immediate = 0; + res = rb_rescue(rb_eval_string, (VALUE)arg, ip_eval_rescue, (VALUE)&failed); + rb_trap_immediate = old_trapflg; + Tcl_ResetResult(interp); if (failed) { - Tcl_AppendResult(interp, RSTRING(failed)->ptr, (char*)NULL); - return TCL_ERROR; + VALUE eclass = CLASS_OF(failed); + Tcl_AppendResult(interp, STR2CSTR(failed), (char*)NULL); + if (eclass == eTkCallbackBreak) { + return TCL_BREAK; + } else if (eclass == eTkCallbackContinue) { + return TCL_CONTINUE; + } else { + return TCL_ERROR; + } } /* result must be string or nil */ @@ -99,12 +156,11 @@ ip_ruby(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[]) DUMP1("(rb_eval_string result) nil"); return TCL_OK; } - Check_Type(res, T_STRING); /* copy result to the tcl interpreter */ - DUMP2("(rb_eval_string result) %s", RSTRING(res)->ptr); + DUMP2("(rb_eval_string result) %s", STR2CSTR(res)); DUMP1("Tcl_AppendResult"); - Tcl_AppendResult(interp, RSTRING(res)->ptr, (char *)NULL); + Tcl_AppendResult(interp, STR2CSTR(res), (char *)NULL); return TCL_OK; } @@ -115,6 +171,7 @@ ip_free(struct tcltkip *ptr) { DUMP1("Tcl_DeleteInterp"); Tcl_DeleteInterp(ptr->ip); + free(ptr); } /* create and initialize interpreter */ @@ -135,20 +192,26 @@ ip_new(VALUE self) /* from Tcl_AppInit() */ DUMP1("Tcl_Init"); if (Tcl_Init(ptr->ip) == TCL_ERROR) { - Fail("Tcl_Init"); + rb_raise(rb_eRuntimeError, "Tcl_Init"); } DUMP1("Tk_Init"); if (Tk_Init(ptr->ip) == TCL_ERROR) { - Fail("Tk_Init"); + rb_raise(rb_eRuntimeError, "Tk_Init"); } DUMP1("Tcl_StaticPackage(\"Tk\")"); Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, (Tcl_PackageInitProc *) NULL); /* add ruby command to the interpreter */ +#if TCL_MAJOR_VERSION >= 8 + DUMP1("Tcl_CreateObjCommand(\"ruby\")"); + Tcl_CreateObjCommand(ptr->ip, "ruby", ip_ruby, (ClientData *)NULL, + (Tcl_CmdDeleteProc *)NULL); +#else DUMP1("Tcl_CreateCommand(\"ruby\")"); Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby, (ClientData *)NULL, (Tcl_CmdDeleteProc *)NULL); +#endif return obj; } @@ -157,6 +220,7 @@ ip_new(VALUE self) static VALUE ip_eval(VALUE self, VALUE str) { + char *s; char *buf; /* Tcl_Eval requires re-writable string region */ struct tcltkip *ptr; /* tcltkip data struct */ @@ -164,18 +228,162 @@ ip_eval(VALUE self, VALUE str) Data_Get_Struct(self, struct tcltkip, ptr); /* call Tcl_Eval() */ - Check_Type(str, T_STRING); - buf = ALLOCA_N(char,RSTRING(str)->len+1); - strcpy(buf, RSTRING(str)->ptr); + s = STR2CSTR(str); + buf = ALLOCA_N(char, strlen(s)+1); + strcpy(buf, s); DUMP2("Tcl_Eval(%s)", buf); ptr->return_value = Tcl_Eval(ptr->ip, buf); if (ptr->return_value == TCL_ERROR) { - Fail(ptr->ip->result); + rb_raise(rb_eRuntimeError, ptr->ip->result); } DUMP2("(TCL_Eval result) %d", ptr->return_value); /* pass back the result (as string) */ - return(str_new2(ptr->ip->result)); + return(rb_str_new2(ptr->ip->result)); +} + + +static VALUE +ip_toUTF8(VALUE self, VALUE str, VALUE encodename) +{ +#ifndef TCL_UTF_MAX + return str; +#else + Tcl_Interp *interp; + Tcl_Encoding encoding; + Tcl_DString dstr; + struct tcltkip *ptr; + char *buff1,*buff2; + + Data_Get_Struct(self,struct tcltkip, ptr); + interp = ptr->ip; + + encoding = Tcl_GetEncoding(interp,STR2CSTR(encodename)); + buff1 = ALLOCA_N(char,strlen(STR2CSTR(str))+1); + strcpy(buff1,STR2CSTR(str)); + + Tcl_DStringInit(&dstr); + Tcl_DStringFree(&dstr); + Tcl_ExternalToUtfDString(encoding,buff1,strlen(buff1),&dstr); + buff2 = ALLOCA_N(char,Tcl_DStringLength(&dstr)+1); + strcpy(buff2,Tcl_DStringValue(&dstr)); + + Tcl_FreeEncoding(encoding); + Tcl_DStringFree(&dstr); + + return rb_str_new2(buff2); +#endif +} + +static VALUE +ip_fromUTF8(VALUE self, VALUE str, VALUE encodename) +{ +#ifndef TCL_UTF_MAX + return str; +#else + Tcl_Interp *interp; + Tcl_Encoding encoding; + Tcl_DString dstr; + struct tcltkip *ptr; + char *buff1,*buff2; + + Data_Get_Struct(self,struct tcltkip, ptr); + interp = ptr->ip; + + encoding = Tcl_GetEncoding(interp,STR2CSTR(encodename)); + buff1 = ALLOCA_N(char,strlen(STR2CSTR(str))+1); + strcpy(buff1,STR2CSTR(str)); + + Tcl_DStringInit(&dstr); + Tcl_DStringFree(&dstr); + Tcl_UtfToExternalDString(encoding,buff1,strlen(buff1),&dstr); + buff2 = ALLOCA_N(char,Tcl_DStringLength(&dstr)+1); + strcpy(buff2,Tcl_DStringValue(&dstr)); + + Tcl_FreeEncoding(encoding); + Tcl_DStringFree(&dstr); + + return rb_str_new2(buff2); +#endif +} + + +static VALUE +ip_invoke(int argc, VALUE *argv, VALUE obj) +{ + struct tcltkip *ptr; /* tcltkip data struct */ + int i; + int object = 0; + Tcl_CmdInfo info; + char *cmd; + char **av = (char **)NULL; +#if TCL_MAJOR_VERSION >= 8 + Tcl_Obj **ov = (Tcl_Obj **)NULL; + Tcl_Obj *resultPtr; +#endif + + /* get the data struct */ + Data_Get_Struct(obj, struct tcltkip, ptr); + + /* get the command name string */ + cmd = STR2CSTR(argv[0]); + + /* map from the command name to a C procedure */ + if (!Tcl_GetCommandInfo(ptr->ip, cmd, &info)) { + rb_raise(rb_eNameError, "invalid command name `%s'", cmd); + } +#if TCL_MAJOR_VERSION >= 8 + object = info.isNativeObjectProc; +#endif + + /* memory allocation for arguments of this command */ + if (object) { +#if TCL_MAJOR_VERSION >= 8 + /* object interface */ + ov = (Tcl_Obj **)ALLOCA_N(Tcl_Obj *, argc+1); + for (i = 0; i < argc; ++i) { + char *s = STR2CSTR(argv[i]); + ov[i] = Tcl_NewStringObj(s, strlen(s)); + } + ov[argc] = (Tcl_Obj *)NULL; +#endif + } else { + /* string interface */ + av = (char **)ALLOCA_N(char *, argc+1); + for (i = 0; i < argc; ++i) { + char *s = STR2CSTR(argv[i]); + + av[i] = ALLOCA_N(char, strlen(s)+1); + strcpy(av[i], s); + } + av[argc] = (char *)NULL; + } + + Tcl_ResetResult(ptr->ip); + + /* Invoke the C procedure */ + if (object) { +#if TCL_MAJOR_VERSION >= 8 + int dummy; + ptr->return_value = (*info.objProc)(info.objClientData, + ptr->ip, argc, ov); + + /* get the string value from the result object */ + resultPtr = Tcl_GetObjResult(ptr->ip); + Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &dummy), + TCL_VOLATILE); +#endif + } else { + ptr->return_value = (*info.proc)(info.clientData, + ptr->ip, argc, av); + } + + if (ptr->return_value == TCL_ERROR) { + rb_raise(rb_eRuntimeError, ptr->ip->result); + } + + /* pass back the result (as string) */ + return(rb_str_new2(ptr->ip->result)); } /* get return code from Tcl_Eval() */ @@ -190,27 +398,44 @@ ip_retval(VALUE self) return (INT2FIX(ptr->return_value)); } +#ifdef __MACOS__ +static void +_macinit() +{ + tcl_macQdPtr = &qd; /* setup QuickDraw globals */ + Tcl_MacSetEventProc(TkMacConvertEvent); /* setup event handler */ +} +#endif + /*---- initialization ----*/ void Init_tcltklib() { extern VALUE rb_argv0; /* the argv[0] */ VALUE lib = rb_define_module("TclTkLib"); - VALUE ip = rb_define_class("TclTkIp", cObject); + VALUE ip = rb_define_class("TclTkIp", rb_cObject); + + eTkCallbackBreak = rb_define_class("TkCallbackBreak", rb_eStandardError); + eTkCallbackContinue = rb_define_class("TkCallbackContinue",rb_eStandardError); rb_define_module_function(lib, "mainloop", lib_mainloop, 0); rb_define_singleton_method(ip, "new", ip_new, 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, 0); +#ifdef __MACOS__ + _macinit(); +#endif + /*---- initialize tcl/tk libraries ----*/ /* from Tk_Main() */ DUMP1("Tcl_FindExecutable"); Tcl_FindExecutable(RSTRING(rb_argv0)->ptr); - - rb_define_variable("$tk_thread_safe", &thread_safe); } /* eof */ -- cgit v1.2.3