summaryrefslogtreecommitdiff
path: root/ext/tcltklib
diff options
context:
space:
mode:
authornagai <nagai@b2dd03c8-39d4-4d8f-98ff-823fe69b080e>2004-05-01 16:09:54 +0000
committernagai <nagai@b2dd03c8-39d4-4d8f-98ff-823fe69b080e>2004-05-01 16:09:54 +0000
commit4c4631c2daaf7b2418c1f0e39292c8ee27a64813 (patch)
treedfeb96c4772df8caba4e01e749c8f3e1262f8fe0 /ext/tcltklib
parentce23680755e4e9ab0eed9dc6adb091ef7f1c58cb (diff)
* renewal Ruby/Tk
git-svn-id: svn+ssh://ci.ruby-lang.org/ruby/trunk@6237 b2dd03c8-39d4-4d8f-98ff-823fe69b080e
Diffstat (limited to 'ext/tcltklib')
-rw-r--r--ext/tcltklib/MANIFEST2
-rw-r--r--ext/tcltklib/MANUAL.eng569
-rw-r--r--ext/tcltklib/MANUAL.euc114
-rw-r--r--ext/tcltklib/README.1st2
-rw-r--r--ext/tcltklib/demo/lines3.rb54
-rw-r--r--ext/tcltklib/demo/lines4.rb54
-rw-r--r--ext/tcltklib/extconf.rb76
-rw-r--r--ext/tcltklib/tcltklib.c3614
8 files changed, 3902 insertions, 583 deletions
diff --git a/ext/tcltklib/MANIFEST b/ext/tcltklib/MANIFEST
index e06547a6aae..e408dc3ee80 100644
--- a/ext/tcltklib/MANIFEST
+++ b/ext/tcltklib/MANIFEST
@@ -11,6 +11,8 @@ lib/tcltk.rb
demo/lines0.tcl
demo/lines1.rb
demo/lines2.rb
+demo/lines3.rb
+demo/lines4.rb
demo/safeTk.rb
sample/sample0.rb
sample/sample1.rb
diff --git a/ext/tcltklib/MANUAL.eng b/ext/tcltklib/MANUAL.eng
index a037d18d414..20e966d223c 100644
--- a/ext/tcltklib/MANUAL.eng
+++ b/ext/tcltklib/MANUAL.eng
@@ -1,5 +1,5 @@
(tof)
- 2003/10/17 Hidetoshi NAGAI
+ 2004/03/28 Hidetoshi NAGAI
This document discribes about the 'tcltklib' library. Although there
is the 'tcltk' library (tcltk.rb) under this directory, no description
@@ -41,224 +41,367 @@ module TclTklib
: a target event. With this flag, doesn't wait and returns
: false if there is no target event for processing.
- [module methods]
- mainloop(check_root = true)
- : Starts the eventloop. If 'check_root' is true, this method
- : doesn't return when a root widget exists.
- : If 'check_root' is false, doen't return by the other
- : reasons than exceptions.
-
- mainloop_watchdog(check_root = true)
- : On the normal eventloop, some kinds of callback operations
- : cause deadlock. To avoid some of such deadlocks, this
- : method starts an eventloop and a watchdog-thread.
-
- do_one_event(flag = TclTkLib::EventFlag::ALL |
- TclTkLib::EventFlag::DONT_WAIT)
- : Do one event for processing. When processed an event,
- : returns true.
- : If NOT set DONT_WAIT flag, this method waits occurrence of
- : a target event.
- : If set DONT_WAIT flag and no event for processing, returns
- : false immediately.
- : If $SAFE >= 4, or $SAFE >= 1 and the flag is tainted,
- : force to set DONT_WAIT flag.
-
- set_eventloop_tick(timer_tick)
- : Define the interval of thread-switching with an integer
- : value of mili-seconds.
- : Default timer_tick is 0. It means that thread-switching
- : is based on the count of processed events.
- : ( see 'set_eventloop_weight' method )
- : However, if the eventloop thread is the only thread,
- : timer_tick cannt be set to 0. If 0, then is set to 100 ms
- : automatically (see NO_THREAD_INTERRUPT_TIME on tcltklib.c).
- : On $SAFE >= 4, cannot call this method.
-
- get_eventloop_tick
- : Get current value of 'timer_tick'
-
- set_no_event_wait(no_event_wait)
- : Define sleeping time of the eventloop when two or more
- : thread are running and there is no event for processing.
- : Default value is 20 (ms).
- : If the eventloop thread is the only thread, this value is
- : invalid.
- : On $SAFE >= 4, cannot call this method.
-
- get_no_event_wait
- : Get current value of 'no_event_wait'.
-
- set_eventloop_weight(loop_max, no_event_tick)
- : Define the weight parameters for the eventloop thread.
- : That is invalid when the eventloop is the only thread.
- : 'loop_max' is the max events for thread-switching.
- : 'no_event_tick' is the increment value of the event count
- : when no event for processing (And then, the eventloop thead
- : sleeps 'no_event_wait' mili-seconds).
- : 'loop_max == 800' and 'no_event_tick == 10' are defalut.
- : On $SAFE >= 4, cannot call this method.
-
- get_eventloop_weight
- : Get current values of 'loop_max' and 'no_event_tick'.
-
- mainloop_abort_on_exception=(bool)
- : Define whether the eventloop stops on exception or not.
- : If true (default value), stops on exception.
- : If false, show a warinig message but ignore the exception.
- : If nil, no warning message and ignore the excepsion.
- : This parameter is sometimes useful when multiple Tk
- : interpreters are working. Because the only one eventloop
- : admins all Tk interpreters, sometimes exception on a
- : interpreter kills the eventloop thread. Even if such
- : situation, when abort_on_exception == false or nil,
- : the eventloop ignores the exception and continue to working.
- : On $SAFE >= 4, cannot call this method.
-
- mainloop_abort_on_exception
- : Get current status of that.
-
- num_of_mainwindows
- : Returns the number of main-windows (root-widget).
- : Because there is only one main-window for one Tk interpreter,
- : the value is same to the number of interpreters which has
- : available Tk functions.
+ module TclTkLib::VarAccessFlag
+ : Defines flags to give '_get_variable' and so on. When to give,
+ : please use bit-operator (e.g. GLOBAL_ONLY | LEAVE_ERR_MSG ).
+ [constants]
+ NONE
+ : Is 0. It means "set no flag".
+
+ GLOBAL_ONLY
+ : (site Tcl/Tk's man page)
+ : Under normal circumstances the procedures look up
+ : variables as follows: If a procedure call is active
+ : in interp, a variable is looked up at the current
+ : level of procedure call. Otherwise, a variable is
+ : looked up first in the current namespace, then in
+ : the global namespace. However, if this bit is set
+ : in flags then the variable is looked up only in the
+ : global namespace even if there is a procedure call
+ : active. If both GLOBAL_ONLY and NAMESPACE_ONLY are
+ : given, GLOBAL_ONLY is ignored.
+ :
+ : *** ATTENTION ***
+ : Tcl7.6 doesn't have namespaces. So NAMESPACE_ONLY
+ : is defined as 0, and then GLOBAL_ONLY is available
+ : even if flag is (GLOBAL_ONLY | NAMESPACE_ONLY).
+
+ NAMESPACE_ONLY
+ : (site Tcl/Tk's man page)
+ : Under normal circumstances the procedures look up
+ : variables as follows: If a procedure call is active
+ : in interp, a variable is looked up at the current
+ : level of procedure call. Otherwise, a variable is
+ : looked up first in the current namespace, then in
+ : the global namespace. However, if this bit is set
+ : in flags then the variable is looked up only in the
+ : current namespace even if there is a procedure call
+ : active.
+ :
+ : *** ATTENTION ***
+ : Tcl7.6 doesn't have namespaces. So NAMESPACE_ONLY
+ : is defined as 0.
+
+ LEAVE_ERR_MSG
+ : (site Tcl/Tk's man page)
+ : If an error is returned and this bit is set in flags,
+ : then an error message will be left in the interpreter's
+ : result, where it can be retrieved with Tcl_GetObjResult
+ : or Tcl_GetStringResult. If this flag bit isn't set then
+ : no error message is left and the interpreter's result
+ : will not be modified.
+
+ APPEND_VALUE
+ : (site Tcl/Tk's man page)
+ : If this bit is set then newValue is appended to the
+ : current value, instead of replacing it. If the variable
+ : is currently undefined, then this bit is ignored.
+
+ LIST_ELEMENT
+ : (site Tcl/Tk's man page)
+ : If this bit is set, then newValue is converted to a
+ : valid Tcl list element before setting (or appending
+ : to) the variable. A separator space is appended before
+ : the new list element unless the list element is going
+ : to be the first element in a list or sublist (i.e. the
+ : variable's current value is empty, or contains the
+ : single character ``{'', or ends in `` }'').
+
+ PARSE_VARNAME
+ : (site Tcl/Tk's man page)
+ : If this bit is set when calling _set_variable and so
+ : on, var_name argument may contain both an array and an
+ : element name: if the name contains an open parenthesis
+ : and ends with a close parenthesis, then the value
+ : between the parentheses is treated as an element name
+ : (which can have any string value) and the characters
+ : before the first open parenthesis are treated as the
+ : name of an array variable. If the flag PARSE_VARNAME
+ : is given, index_name argument should be 'nil' since the
+ : array and element names are taken from var_name.
+ :
+ : *** ATTENTION ***
+ : Tcl7.6 doesn't have this flag. So PARSE_VARNAME is
+ : defined as 0.
+
+ [module methods]
+ mainloop(check_root = true)
+ : Starts the eventloop. If 'check_root' is true, this method
+ : doesn't return when a root widget exists.
+ : If 'check_root' is false, doen't return by the other
+ : reasons than exceptions.
+
+ mainloop_watchdog(check_root = true)
+ : On the normal eventloop, some kinds of callback operations
+ : cause deadlock. To avoid some of such deadlocks, this
+ : method starts an eventloop and a watchdog-thread.
+
+ do_one_event(flag = TclTkLib::EventFlag::ALL |
+ TclTkLib::EventFlag::DONT_WAIT)
+ : Do one event for processing. When processed an event,
+ : returns true.
+ : If NOT set DONT_WAIT flag, this method waits occurrence of
+ : a target event.
+ : If set DONT_WAIT flag and no event for processing, returns
+ : false immediately.
+ : If $SAFE >= 4, or $SAFE >= 1 and the flag is tainted,
+ : force to set DONT_WAIT flag.
+
+ set_eventloop_tick(timer_tick)
+ : Define the interval of thread-switching with an integer
+ : value of mili-seconds.
+ : Default timer_tick is 0. It means that thread-switching
+ : is based on the count of processed events.
+ : ( see 'set_eventloop_weight' method )
+ : However, if the eventloop thread is the only thread,
+ : timer_tick cannt be set to 0. If 0, then is set to 100 ms
+ : automatically (see NO_THREAD_INTERRUPT_TIME on tcltklib.c).
+ : On $SAFE >= 4, cannot call this method.
+
+ get_eventloop_tick
+ : Get current value of 'timer_tick'
+
+ set_no_event_wait(no_event_wait)
+ : Define sleeping time of the eventloop when two or more
+ : thread are running and there is no event for processing.
+ : Default value is 20 (ms).
+ : If the eventloop thread is the only thread, this value is
+ : invalid.
+ : On $SAFE >= 4, cannot call this method.
+
+ get_no_event_wait
+ : Get current value of 'no_event_wait'.
+
+ set_eventloop_weight(loop_max, no_event_tick)
+ : Define the weight parameters for the eventloop thread.
+ : That is invalid when the eventloop is the only thread.
+ : 'loop_max' is the max events for thread-switching.
+ : 'no_event_tick' is the increment value of the event count
+ : when no event for processing (And then, the eventloop thead
+ : sleeps 'no_event_wait' mili-seconds).
+ : 'loop_max == 800' and 'no_event_tick == 10' are defalut.
+ : On $SAFE >= 4, cannot call this method.
+
+ get_eventloop_weight
+ : Get current values of 'loop_max' and 'no_event_tick'.
+
+ mainloop_abort_on_exception=(bool)
+ : Define whether the eventloop stops on exception or not.
+ : If true (default value), stops on exception.
+ : If false, show a warinig message but ignore the exception.
+ : If nil, no warning message and ignore the excepsion.
+ : This parameter is sometimes useful when multiple Tk
+ : interpreters are working. Because the only one eventloop
+ : admins all Tk interpreters, sometimes exception on a
+ : interpreter kills the eventloop thread. Even if such
+ : situation, when abort_on_exception == false or nil,
+ : the eventloop ignores the exception and continue to working.
+ : On $SAFE >= 4, cannot call this method.
+
+ mainloop_abort_on_exception
+ : Get current status of that.
+
+ num_of_mainwindows
+ : Returns the number of main-windows (root-widget).
+ : Because there is only one main-window for one Tk interpreter,
+ : the value is same to the number of interpreters which has
+ : available Tk functions.
+
+ _merge_tklist(str, str, ... )
+ : Get a Tcl's list string from arguments with a Tcl/Tk's
+ : library function. Each arguemnt is converted to a valid
+ : Tcl list element.
+
+ _conv_listelement(str)
+ : Convert the argument to a valid Tcl list element with
+ : Tcl/Tk's library function.
+
+ _toUTF8(str, encoding)
+ _fromUTF8(str, encoding)
+ : Call the function (which is internal function of Tcl/Tk) to
+ : convert to/from a UTF8 string.
+
+ _subst_UTF_backslash(str)
+ _subst_Tcl_backslash(str)
+ : Substitute backslash sequence with Tcl's rule (include \uhhhh;
+ : give a sixteen-bit hexadecimal value for Unicode character).
+ : _subst_Tcl_backslash method parses all backslash sequence.
+ : _subst_UTF_backslash method parses \uhhhh only.
class TclTkIp
[class methods]
- new(ip_name=nil, options='')
- : Generate an instance of TclTkIp class.
- : If 'ip_name' argument is given as a string, it is the name
- : of the Tk interpreter which is shown by 'winfo interps'
- : command.
- : 'options' argument accepts a string which is the command
- : line options of wish; such as '-geometry' or '-use'.
- : The information is used to generate the root widget of the
- : interpreter.
- : ( e.g. TclTkIp.new('FOO', '-geometry 500x200 -use 0x2200009') )
- : If is given nil or falsr for the 'option' argument, generates
- : the Tcl interpreter without Tk library. Then the interpreter
- : doesn't need GUI environment. Therefore, even if a window
- : system doesn't exist or cannot be used, Ruby can control the
- : Tcl interpreter and the extention libraries loaded on the
- : interpreter.
-
- [instance methods]
- create_slave(name, safe=false)
- : Create a slave interpreter.
- : The parent of the interpreter is the receiver of this method.
- : The name of the slave interpreter is given by 'name' argument.
- : The 'safe' argument decides whether the slave interpreter is
- : created as a safe interpreter or not. If true, create a safe
- : interpreter. Default is false. However, if the parent
- : interpreter is a safe interpreter, the created interpreter is
- : a safe interpreter (ignore 'safe' argument value).
- : If $SAFE >= 4, can create a safe interpreter only.
-
- make_safe
- : Make the interpreter to the safe interpreter, and returns
- : self. If fail, raise RuntimeError.
-
- safe?
- : Check whether the interpreter is the safe interpreter.
- : If is the safe interpreter, returns true.
-
- delete
- : Delete the interpreter.
- : The deleted interpreter doesn't accept command and then
- : raise an exception.
-
- deleted?
- : Check whether the interpreter is already deleted.
- : If deleted, returns true.
-
- restart
- : Restart Tk part of the interpreter.
- : Use this when you need Tk functions after destroying the
- : root widget.
- : On $SAFE >= 4, cannot call this method.
-
- _eval(str)
- _invoke(*args)
- : Estimates the arguments as a command on the Tk interpreter.
- : The argument of _eval is a script of Tcl/Tk.
- : Each argument of _invoke is a token of one command line of
- : Tcl/Tk.
- : Because the operation of _invoke doesn't through the
- : command line parser of Tk interpreter, the cost of
- : estimation is smaller than _eval. However, auto_load
- : mechanism of the Tk interpreter doesn't work on _invoke.
- : So _invoke can call only the command which already
- : registered on the interpreter by 'load' command and so on.
- : On _eval command, auto_load mechanism words. So if succeed
- : to _eval and regist the command once, after that, the
- : command can be called by _invoke.
-
- _toUTF8(str, encoding)
- _fromUTF8(str, encoding)
- : Call the function (which is internal function of Tcl/Tk) to
- : convert to/from a UTF8 string.
-
- _thread_vwait(var_name)
- _thread_tkwait(mode, target)
- : 'vwait' or 'tkwait' with thread support.
- : The difference from normal 'vwait' or 'tkwait' command is
- : doing independent wait from the vwait stack when they are
- : called on the other thread than the eventloop thread.
- : In the case of Tcl/Tk's vwait / tkwait, if 2nd vwait /
- : tkwait is called on waiting for 1st vwait / tkwait,
- : returns the order of [2nd]->[1st] regardless of the order
- : of when the wait condition was fulfilled.
- : If _thread_vwait / _thread_tkwait is called on the
- : eventloop thread, there is no difference from vwait /
- : tkwait. But if called on the other thread than the
- : eventloop, stops the thread. And when the wait condition
- : is fulfilled, the thread restarts. The meaning of
- : "independent from the vwait stack" is that the timing of
- : restarting is independent from the waiting status of the
- : other threads. That is, even if the eventloop thread is
- : waiting by vwait and is not fulfilled the condition,
- : _thread_vwait completes the waiting when its waiting
- : condition is fulfilled and the thread which stopped by
- : _thread_vwait can continue the operation.
-
- _return_value
- : Get the last result value on the interpreter.
-
- mainloop
- mainloop_watchdog
- : If on the slave interpreter, never start an eventloop and
- : returns nil.
- : With the exception that, same to the TclTkLib module method
- : with the same name.
-
- do_one_event
- : With the exception that the argument is forced to set
- : DONT_WAIT flag on the slave interpreter, same to
- : TclTkLib#do_one_event.
-
- set_eventloop_tick
- get_eventloop_tick
- set_no_event_wait
- get_no_event_wait
- set_eventloop_weight
- get_eventloop_weight
- mainloop_abort_on_exception
- mainloop_abort_on_exception=
- : With the exception that it is ignored to set value on the
- : slave interpreter, same to the TclTkLib module method with
- : the same name.
+ new(ip_name=nil, options='')
+ : Generate an instance of TclTkIp class.
+ : If 'ip_name' argument is given as a string, it is the name
+ : of the Tk interpreter which is shown by 'winfo interps'
+ : command.
+ : 'options' argument accepts a string which is the command
+ : line options of wish; such as '-geometry' or '-use'.
+ : The information is used to generate the root widget of the
+ : interpreter.
+ : ( e.g. TclTkIp.new('FOO', '-geometry 500x200 -use 0x2200009') )
+ : If is given nil or falsr for the 'option' argument, generates
+ : the Tcl interpreter without Tk library. Then the interpreter
+ : doesn't need GUI environment. Therefore, even if a window
+ : system doesn't exist or cannot be used, Ruby can control the
+ : Tcl interpreter and the extention libraries loaded on the
+ : interpreter.
+
+ [instance methods]
+ create_slave(name, safe=false)
+ : Create a slave interpreter.
+ : The parent of the interpreter is the receiver of this method.
+ : The name of the slave interpreter is given by 'name' argument.
+ : The 'safe' argument decides whether the slave interpreter is
+ : created as a safe interpreter or not. If true, create a safe
+ : interpreter. Default is false. However, if the parent
+ : interpreter is a safe interpreter, the created interpreter is
+ : a safe interpreter (ignore 'safe' argument value).
+ : If $SAFE >= 4, can create a safe interpreter only.
+
+ make_safe
+ : Make the interpreter to the safe interpreter, and returns
+ : self. If fail, raise RuntimeError.
+
+ safe?
+ : Check whether the interpreter is the safe interpreter.
+ : If is the safe interpreter, returns true.
+
+ delete
+ : Delete the interpreter.
+ : The deleted interpreter doesn't accept command and then
+ : raise an exception.
+
+ deleted?
+ : Check whether the interpreter is already deleted.
+ : If deleted, returns true.
+
+ restart
+ : Restart Tk part of the interpreter.
+ : Use this when you need Tk functions after destroying the
+ : root widget.
+ : On $SAFE >= 4, cannot call this method.
+
+ _eval(str)
+ _invoke(*args)
+ : Estimates the arguments as a command on the Tk interpreter.
+ : The argument of _eval is a script of Tcl/Tk.
+ : Each argument of _invoke is a token of one command line of
+ : Tcl/Tk.
+ : Because the operation of _invoke doesn't through the
+ : command line parser of Tk interpreter, the cost of
+ : estimation is smaller than _eval. However, auto_load
+ : mechanism of the Tk interpreter doesn't work on _invoke.
+ : So _invoke can call only the command which already
+ : registered on the interpreter by 'load' command and so on.
+ : On _eval command, auto_load mechanism words. So if succeed
+ : to _eval and regist the command once, after that, the
+ : command can be called by _invoke.
+
+ _toUTF8(str, encoding)
+ _fromUTF8(str, encoding)
+ : Call the function (which is internal function of Tcl/Tk) to
+ : convert to/from a UTF8 string.
+
+ _thread_vwait(var_name)
+ _thread_tkwait(mode, target)
+ : 'vwait' or 'tkwait' with thread support.
+ : The difference from normal 'vwait' or 'tkwait' command is
+ : doing independent wait from the vwait stack when they are
+ : called on the other thread than the eventloop thread.
+ : In the case of Tcl/Tk's vwait / tkwait, if 2nd vwait /
+ : tkwait is called on waiting for 1st vwait / tkwait,
+ : returns the order of [2nd]->[1st] regardless of the order
+ : of when the wait condition was fulfilled.
+ : If _thread_vwait / _thread_tkwait is called on the
+ : eventloop thread, there is no difference from vwait /
+ : tkwait. But if called on the other thread than the
+ : eventloop, stops the thread. And when the wait condition
+ : is fulfilled, the thread restarts. The meaning of
+ : "independent from the vwait stack" is that the timing of
+ : restarting is independent from the waiting status of the
+ : other threads. That is, even if the eventloop thread is
+ : waiting by vwait and is not fulfilled the condition,
+ : _thread_vwait completes the waiting when its waiting
+ : condition is fulfilled and the thread which stopped by
+ : _thread_vwait can continue the operation.
+
+ _return_value
+ : Get the last result value on the interpreter.
+
+ _get_variable(var_name, flag)
+ _get_variable2(var_name, index_name, flag)
+ : Get the current value of a variable. If specified a
+ : index_name (see also the PARSE_VARNAME flag), get the
+ : value of the index_name element.
+
+ _set_variable(var_name, value, flag)
+ _set_variable2(var_name, index_name, value, flag)
+ : Create or modify a variable. If specified a index_name
+ : (see also the PARSE_VARNAME flag), create or modify the
+ : index_name element.
+
+ _unset_variable(var_name)
+ _unset_variable2(var_name, index_name)
+ : Remove a variable. If specified a index_name (see also
+ : the PARSE_VARNAME flag), remove the index_name element.
+
+ _get_global_var(var_name)
+ _get_global_var2(var_name, index_name)
+ _set_global_var(var_name, value)
+ _set_global_var2(var_name, index_name, value)
+ _unset_global_var(var_name)
+ _unset_global_var2(var_name, index_name)
+ : Call the associated method with the flag argument
+ : (GLOBAL_ONLY | LEAVE_ERR_MSG).
+
+ _split_tklist(str)
+ : Split the argument with Tcl/Tk's library function and
+ : get an array as a list of Tcl list elements.
+
+ _merge_tklist(str, str, ... )
+ : Get a Tcl's list string from arguments with a Tcl/Tk's
+ : library function. Each arguemnt is converted to a valid
+ : Tcl list element.
+
+ _conv_listelement(str)
+ : Convert the argument to a valid Tcl list element with
+ : Tcl/Tk's library function.
+
+ mainloop
+ mainloop_watchdog
+ : If on the slave interpreter, never start an eventloop and
+ : returns nil.
+ : With the exception that, same to the TclTkLib module method
+ : with the same name.
+
+ do_one_event
+ : With the exception that the argument is forced to set
+ : DONT_WAIT flag on the slave interpreter, same to
+ : TclTkLib#do_one_event.
+
+ set_eventloop_tick
+ get_eventloop_tick
+ set_no_event_wait
+ get_no_event_wait
+ set_eventloop_weight
+ get_eventloop_weight
+ mainloop_abort_on_exception
+ mainloop_abort_on_exception=
+ : With the exception that it is ignored to set value on the
+ : slave interpreter, same to the TclTkLib module method with
+ : the same name.
class TkCallbackBreak < StandardError
class TkCallbackContinue < StandardError
- : They are exception classes to break or continue the Tk callback
- : operation.
- : If raise TkCallbackBreak on the callback procedure, Ruby returns
- : 'break' code to Tk interpreter (Then the Tk interpreter will
- : break the operation for the current event).
- : If raise TkCallbackContinue, returns 'continue' code (Then the Tk
- : interpreter will break the operateion for the current bindtag and
- : starts the operation for the next buindtag for the current event).
+ : They are exception classes to break or continue the Tk callback
+ : operation.
+ : If raise TkCallbackBreak on the callback procedure, Ruby returns
+ : 'break' code to Tk interpreter (Then the Tk interpreter will
+ : break the operation for the current event).
+ : If raise TkCallbackContinue, returns 'continue' code (Then the Tk
+ : interpreter will break the operateion for the current bindtag and
+ : starts the operation for the next buindtag for the current event).
(eof)
diff --git a/ext/tcltklib/MANUAL.euc b/ext/tcltklib/MANUAL.euc
index 9f9c77da02e..baddcaf54bd 100644
--- a/ext/tcltklib/MANUAL.euc
+++ b/ext/tcltklib/MANUAL.euc
@@ -1,5 +1,5 @@
(tof)
- 2003/10/17 Hidetoshi NAGAI
+ 2004/03/28 Hidetoshi NAGAI
本ドキュメントには古い tcltk ライブラリ,tcltklib ライブラリの説明
が含まれていますが,その記述内容は古いものとなっています.
@@ -175,6 +175,52 @@ require "tcltklib" すると, 以下のモジュール, クラスが利用可能です.
: 処理対象イベントが存在しない場合に,イベント発生を待たず
: に do_one_event を終了 ( false を返す ) する
+ モジュール TclTkLib::VarAccessFlag
+ : _get_variable などでのフラグを指定するためのもの.フラグに
+ : は以下の定数を OR で連結して与える.
+
+ 定数 NONE
+ : 値は 0 で,何もフラグを指定していないのに等しい.
+
+ 定数 GLOBAL_ONLY
+ : 通常,変数の検索はまず手続き呼び出しを行ったレベルで検
+ : 索し,次に現在の名前空間で検索,最後にグローバル空間で
+ : 検索を行う.しかし,このフラグが指定された場合には,グ
+ : ローバル空間でのみ検索する.
+ : もし GLOBAL_ONLY と NAMESPACE_ONLY とが両方指定された場
+ : 合には,GLOBAL_ONLY の指定は無視される.
+
+ 定数 NAMESPACE_ONLY
+ : このフラグが指定された場合には,現在の名前空間でのみ変
+ : 数の検索を行う.GLOBAL_ONLY の説明も参照すること.
+
+ 定数 LEAVE_ERR_MSG
+ : 変数アクセスにおいてエラーが発生した場合,このフラグが
+ : 指定されていれば,実行結果として Tcl インタープリタにエ
+ : ラーメッセージが残される.このフラグが指定されていなけ
+ : れば,エラーメッセージは一切残されない.
+
+ 定数 APPEND_VALUE
+ : このフラグが指定されていた場合,変数の値を置き換えので
+ : はなく,現在の値に代入値が追加 (append; 文字列連結) さ
+ : れる.変数が未定義あった場合,このフラグは無視される.
+
+ 定数 LIST_ELEMENT
+ : このフラグが指定されていた場合,代入値はまず Tcl のリス
+ : ト要素として適切となるように変換される.代入値がリスト
+ : (またはサブリスト) の最初の要素となるのでない限り,代入
+ : 値の直前には空白文字が追加される.
+
+ 定数 PARSE_VARNAME
+ : _set_variable などの呼び出しにおいてこのフラグが指定さ
+ : れていた場合,var_name 引数が連想配列名と要素名とを両方
+ : 含む可能性がある (開き括弧を含み,閉じ括弧で終わる) こ
+ : とを示す.その場合,括弧の間が要素名指定,最初の開き括
+ : 弧までが連想配列名として扱われる._set_variable2 などで
+ : このフラグを指定する場合,連想配列名と要素名は var_name
+ : から抽出されるはずであるから,index_name 引数は nil と
+ : せねばならない.
+
モジュールメソッド
mainloop(check_root = true)
: イベントループを起動する.check_root が true であれば,
@@ -277,6 +323,26 @@ require "tcltklib" すると, 以下のモジュール, クラスが利用可能です.
: ので,この値は現在 Tk の機能が有効であるインタープリタの総
: 数に等しい.
+ _merge_tklist(str, str, ... )
+ : Tcl/Tk のライブラリ関数を使って,引数の文字列がそれぞれ
+ : 正しく一つのリスト要素となるように連結した文字列を返す.
+
+ _conv_listelement(str)
+ : Tcl/Tk のライブラリ関数を使って,引数の文字列が Tcl の
+ : 一つのリスト要素として適切な表現になるように変換した文
+ : 字列を返す.
+
+ _toUTF8(str, encoding)
+ _fromUTF8(str, encoding)
+ : Tcl/Tk が内蔵している UTF8 変換処理を呼び出す.
+
+ _subst_UTF_backslash(str)
+ _subst_Tcl_backslash(str)
+ : Tcl のルールでバックスラッシュ記法 ( \uhhhh による
+ : Unicode 文字表現を含む ) を解析する.
+ : _subst_Tcl_backslash はすべてのバックスラッシュ記法を
+ : 置き換えるのに対し,_subst_UTF_backslash は \uhhhh
+ : による Unicode 文字表現だけを置き換える.
クラス TclTkIp
クラスメソッド
@@ -373,6 +439,52 @@ require "tcltklib" すると, 以下のモジュール, クラスが利用可能です.
_return_value
: 直前の Tcl/Tk 上での評価の実行結果としての戻り値を返す.
+ _get_variable(var_name, flag)
+ _get_variable2(var_name, index_name, flag)
+ : Tcl/Tk 上の var という変数名の変数の値を返す.
+ : もし index_name が指定 (PARSE_VARNAME フラグの説明も参照)
+ : された場合は連想配列 var_name の index_name の要素を返す.
+ : flag には変数を検索する際の条件を指定する.flag に与える
+ : 値はモジュール TclTkLib::VarAccessFlag を参照すること.
+
+ _set_variable(var_name, value, flag)
+ _set_variable2(var_name, index_name, value, flag)
+ : Tcl/Tk 上の var という変数名の変数に値を設定する.
+ : もし index_name が指定 (PARSE_VARNAME フラグの説明も参照)
+ : された場合は連想配列 var_name の index_name の要素を設定
+ : する.
+ : flag には変数を検索する際の条件を指定する.flag に与える
+ : 値はモジュール TclTkLib::VarAccessFlag を参照すること.
+
+ _unset_variable(var_name)
+ _unset_variable2(var_name, index_name)
+ : Tcl/Tk 上の var_name という変数名の変数を消去する.
+ : もし index_name が指定 (PARSE_VARNAME フラグの説明も参照)
+ : された場合は連想配列 var_name から index_name の要素だけ
+ : を消去する.
+
+ _get_global_var(var_name)
+ _get_global_var2(var_name, index_name)
+ _set_global_var(var_name, value)
+ _set_global_var2(var_name, index_name, value)
+ _unset_global_var(var_name)
+ _unset_global_var2(var_name, index_name)
+ : それぞれ,対応する変数アクセスメソッドの flag に対して
+ : (GLOBAL_ONLY | LEAVE_ERR_MSG) を与えたもの.
+
+ _split_tklist(str)
+ : Tcl/Tk のライブラリ関数を使って,文字列 str をリストに
+ : 分割する (文字列の配列として返す).
+
+ _merge_tklist(str, str, ... )
+ : Tcl/Tk のライブラリ関数を使って,引数の文字列がそれぞれ
+ : 正しく一つのリスト要素となるように連結した文字列を返す.
+
+ _conv_listelement(str)
+ : Tcl/Tk のライブラリ関数を使って,引数の文字列が Tcl の
+ : 一つのリスト要素として適切な表現になるように変換した文
+ : 字列を返す.
+
mainloop
mainloop_watchdog
: スレーブ IP の場合にはイベントループを起動せずに nil を返す.
diff --git a/ext/tcltklib/README.1st b/ext/tcltklib/README.1st
index 510dd1c2cde..48e3a2b6688 100644
--- a/ext/tcltklib/README.1st
+++ b/ext/tcltklib/README.1st
@@ -8,7 +8,7 @@ some or all of the following options.
--with-tcllib=<libname> (e.g. libtcl8.3.so ==> --with-tcllib=tcl8.3)
--with-tklib=<libname> (e.g. libtk8.3.so ==> --with-tklib=tk8.3)
- --enable_tcltk_stubs (if you force to enable stubs)
+ --enable-tcltk_stubs (if you force to enable stubs)
--with-tcl-dir=<path>
equal to "--with-tcl-include=<path>/include --with-tcl-lib=<path>/lib"
diff --git a/ext/tcltklib/demo/lines3.rb b/ext/tcltklib/demo/lines3.rb
new file mode 100644
index 00000000000..caa50f92e7b
--- /dev/null
+++ b/ext/tcltklib/demo/lines3.rb
@@ -0,0 +1,54 @@
+#! /usr/local/bin/ruby
+
+require "tk"
+
+def drawlines()
+ print Time.now, "\n"
+
+ for j in 0 .. 99
+ print "*"
+ $stdout.flush
+ if (j & 1) != 0
+ col = "blue"
+ else
+ col = "red"
+ end
+ for i in 0 .. 99
+# $a.create(TkcLine, i, 0, 0, 500 - i, "fill"=>col)
+ end
+ end
+
+ print Time.now, "\n"
+
+ for j in 0 .. 99
+ print "*"
+ $stdout.flush
+ if (j & 1) != 0
+ col = "blue"
+ else
+ col = "red"
+ end
+ for i in 0 .. 99
+ $a.create(TkcLine, i, 0, 0, 500 - i, "fill"=>col)
+ end
+ end
+
+ print Time.now, "\n"
+# Tk.root.destroy
+end
+
+$a = TkCanvas.new{
+ height(500)
+ width(500)
+}
+
+$b = TkButton.new{
+ text("draw")
+ command(proc{drawlines()})
+}
+
+TkPack.configure($a, $b, {"side"=>"left"})
+
+Tk.mainloop
+
+# eof
diff --git a/ext/tcltklib/demo/lines4.rb b/ext/tcltklib/demo/lines4.rb
new file mode 100644
index 00000000000..7a1175bce0a
--- /dev/null
+++ b/ext/tcltklib/demo/lines4.rb
@@ -0,0 +1,54 @@
+#! /usr/local/bin/ruby
+
+require "tk"
+
+def drawlines()
+ print Time.now, "\n"
+
+ for j in 0 .. 99
+ print "*"
+ $stdout.flush
+ if (j & 1) != 0
+ col = "blue"
+ else
+ col = "red"
+ end
+ for i in 0 .. 99
+# TkCore::INTERP.__invoke($a.path, "create", "line", i.to_s, '0', '0', (500 - i).to_s, "-fill", col)
+ end
+ end
+
+ print Time.now, "\n"
+
+ for j in 0 .. 99
+ print "*"
+ $stdout.flush
+ if (j & 1) != 0
+ col = "blue"
+ else
+ col = "red"
+ end
+ for i in 0 .. 99
+ TkCore::INTERP.__invoke($a.path, "create", "line", i.to_s, '0', '0', (500 - i).to_s, "-fill", col)
+ end
+ end
+
+ print Time.now, "\n"
+# Tk.root.destroy
+end
+
+$a = TkCanvas.new{
+ height(500)
+ width(500)
+}
+
+$b = TkButton.new{
+ text("draw")
+ command(proc{drawlines()})
+}
+
+TkPack.configure($a, $b, {"side"=>"left"})
+
+Tk.mainloop
+
+# eof
diff --git a/ext/tcltklib/extconf.rb b/ext/tcltklib/extconf.rb
index 575bf78034c..6b2fcdd4acc 100644
--- a/ext/tcltklib/extconf.rb
+++ b/ext/tcltklib/extconf.rb
@@ -2,7 +2,9 @@
require 'mkmf'
-if RUBY_PLATFORM !~ /mswin32|mingw|cygwin|bccwin32/
+is_win32 = (/mswin32|mingw|cygwin|bccwin32/ =~ RUBY_PLATFORM)
+
+unless is_win32
have_library("nsl", "t_open")
have_library("socket", "socket")
have_library("dl", "dlopen")
@@ -25,7 +27,7 @@ def find_tcl(tcllib, stubs)
elsif find_library("tcl", func, *paths)
true
else
- %w[8.4 8.3 8.2 8.0 7.6].find { |ver|
+ %w[8.5 8.4 8.3 8.2 8.1 8.0 7.6].find { |ver|
find_library("tcl#{ver}", func, *paths) or
find_library("tcl#{ver.delete('.')}", func, *paths)
}
@@ -40,7 +42,7 @@ def find_tk(tklib, stubs)
elsif find_library("tk", func, *paths)
true
else
- %w[8.4 8.3 8.2 8.0 4.2].find { |ver|
+ %w[8.5 8.4 8.3 8.2 8.1 8.0 4.2].find { |ver|
find_library("tk#{ver}", func, *paths) or
find_library("tk#{ver.delete('.')}", func, *paths)
}
@@ -48,11 +50,73 @@ def find_tk(tklib, stubs)
end
if have_header("tcl.h") && have_header("tk.h") &&
- (/mswin32|mingw|cygwin|bccwin32/ =~ RUBY_PLATFORM || find_library("X11", "XOpenDisplay",
- "/usr/X11/lib", "/usr/lib/X11", "/usr/X11R6/lib", "/usr/openwin/lib")) &&
+ (is_win32 || find_library("X11", "XOpenDisplay",
+ "/usr/X11/lib", "/usr/lib/X11", "/usr/X11R6/lib", "/usr/openwin/lib")) &&
find_tcl(tcllib, stubs) &&
find_tk(tklib, stubs)
$CPPFLAGS += ' -DUSE_TCL_STUBS -DUSE_TK_STUBS' if stubs
$CPPFLAGS += ' -D_WIN32' if /cygwin/ =~ RUBY_PLATFORM
- create_makefile("tcltklib")
+
+ pthread_enabled = macro_defined?('HAVE_LIBPTHREAD', '#include "ruby.h"')
+
+ if try_run(<<EOF)
+#include <tcl.h>
+static Tcl_ThreadDataKey dataKey;
+int main() { exit((Tcl_GetThreadData(&dataKey, 1) == dataKey)? 1: 0); }
+EOF
+ tcl_enable_thread = true
+ else
+ tcl_enable_thread = false
+ end
+
+ unless pthread_enabled
+ if tcl_enable_thread
+ # ruby -> disable && tcl -> enable
+ puts(%Q'\
+*****************************************************************************
+**
+** PTHREAD SUPPORT MODE ERRROR:
+**
+** Ruby is not compiled with --enable-pthread, but your Tcl/Tk
+** libararies seems to be compiled with "pthread support". This
+** combination possibly cause "Hang-up" or "Segmentation Fault"
+** frequently when Ruby/Tk is working. We NEVER recommend you to
+** create the library under such combination of pthread support.
+**
+** Please recompile Ruby with "--enable-pthread" configure option
+** or recompile Tcl/Tk with "--disable-threads" configure option.
+**
+*****************************************************************************
+')
+ else
+ # ruby -> disable && tcl -> disable
+ create_makefile("tcltklib")
+ end
+ else
+ unless tcl_enable_thread
+ # ruby -> enable && tcl -> disable
+ puts(%Q'\
+*****************************************************************************
+**
+** PTHREAD SUPPORT MODE WARNING:
+**
+** Ruby is compiled with --enable-pthread, but your Tcl/Tk libraries
+** seems to be compiled without "pthread support". Although You can
+** create tcltklib library, this combination may cause memory trouble
+** (e.g. "Hang-up" or "Segmentation Fault"). If you have no reason you
+** must have to keep current pthread support status, we recommend you
+** to make both or neither libraries to support pthread.
+**
+** If you want change the status of pthread support, please recompile
+** Ruby without "--enable-pthread" configure option or recompile Tcl/Tk
+** with "--enable-threads" configure option (if your Tcl/Tk is later
+** than Tcl/Tk8.1).
+**
+*****************************************************************************
+')
+ end
+ # ruby -> enable && tcl -> enable/disable
+
+ create_makefile("tcltklib")
+ end
end
diff --git a/ext/tcltklib/tcltklib.c b/ext/tcltklib/tcltklib.c
index 63dd5936058..eea7ace7fab 100644
--- a/ext/tcltklib/tcltklib.c
+++ b/ext/tcltklib/tcltklib.c
@@ -36,28 +36,62 @@
# endif
# endif
# endif
-#else /* TCL_MAJOR_VERSION == 7 */
+#else /* TCL_MAJOR_VERSION < 8 */
# ifdef CONST
# define CONST84 CONST
# else
+# define CONST
# define CONST84
# endif
#endif
-/* for ruby_debug */
+/* copied from eval.c */
+#define TAG_RETURN 0x1
+#define TAG_BREAK 0x2
+#define TAG_NEXT 0x3
+#define TAG_RETRY 0x4
+#define TAG_REDO 0x5
+#define TAG_RAISE 0x6
+#define TAG_FATAL 0x8
-#define DUMP1(ARG1) if (ruby_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1);}
+/* for ruby_debug */
+#define DUMP1(ARG1) if (ruby_debug) { fprintf(stderr, "tcltklib: %s\n", ARG1); fflush(stderr); }
#define DUMP2(ARG1, ARG2) if (ruby_debug) { fprintf(stderr, "tcltklib: ");\
-fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); }
+fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); fflush(stderr); }
/*
#define DUMP1(ARG1)
#define DUMP2(ARG1, ARG2)
*/
+/* finalize_proc_name */
+static char *finalize_hook_name = "INTERP_FINALIZE_HOOK";
+
/* for callback break & continue */
+static VALUE eTkCallbackReturn;
static VALUE eTkCallbackBreak;
static VALUE eTkCallbackContinue;
+static VALUE eLocalJumpError;
+
+static ID ID_at_enc;
+static ID ID_at_interp;
+
+static ID ID_stop_p;
+static ID ID_kill;
+static ID ID_join;
+
+static ID ID_call;
+static ID ID_backtrace;
+static ID ID_message;
+
+static ID ID_at_reason;
+static ID ID_return;
+static ID ID_break;
+static ID ID_next;
+
+static ID ID_to_s;
+static ID ID_inspect;
+
static VALUE ip_invoke_real _((int, VALUE*, VALUE));
static VALUE ip_invoke _((int, VALUE*, VALUE));
@@ -78,23 +112,45 @@ int *tclDummyMathPtr = (int *) matherr;
struct invoke_queue {
Tcl_Event ev;
int argc;
- VALUE *argv;
- VALUE obj;
- int done;
+#if TCL_MAJOR_VERSION >= 8
+ Tcl_Obj **argv;
+#else /* TCL_MAJOR_VERSION < 8 */
+ char **argv;
+#endif
+ VALUE interp;
+ int *done;
int safe_level;
- VALUE *result;
+ VALUE result;
VALUE thread;
};
struct eval_queue {
Tcl_Event ev;
- VALUE str;
- VALUE obj;
- int done;
+ char *str;
+ int len;
+ VALUE interp;
+ int *done;
int safe_level;
- VALUE *result;
+ VALUE result;
VALUE thread;
};
+
+void
+invoke_queue_mark(struct invoke_queue *q)
+{
+ rb_gc_mark(q->interp);
+ rb_gc_mark(q->result);
+ rb_gc_mark(q->thread);
+}
+
+void
+eval_queue_mark(struct eval_queue *q)
+{
+ rb_gc_mark(q->interp);
+ rb_gc_mark(q->result);
+ rb_gc_mark(q->thread);
+}
+
static VALUE eventloop_thread;
static VALUE watchdog_thread;
@@ -128,9 +184,11 @@ static int loop_counter = 0;
static int check_rootwidget_flag = 0;
#if TCL_MAJOR_VERSION >= 8
-static int ip_ruby _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*));
-#else
-static int ip_ruby _((ClientData, Tcl_Interp *, int, char **));
+static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*));
+static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST*));
+#else /* TCL_MAJOR_VERSION < 8 */
+static int ip_ruby_eval _((ClientData, Tcl_Interp *, int, char **));
+static int ip_ruby_cmd _((ClientData, Tcl_Interp *, int, char **));
#endif
/*---- class TclTkIp ----*/
@@ -161,10 +219,16 @@ static void
_timer_for_tcl(clientData)
ClientData clientData;
{
+ int thr_crit_bup;
+
/* struct invoke_queue *q, *tmp; */
/* VALUE thread; */
DUMP1("called timer_for_tcl");
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
Tk_DeleteTimerHandler(timer_token);
run_timer_flag = 1;
@@ -176,6 +240,8 @@ _timer_for_tcl(clientData)
timer_token = (Tcl_TimerToken)NULL;
}
+ rb_thread_critical = thr_crit_bup;
+
/* rb_thread_schedule(); */
/* tick_counter += event_loop_max; */
}
@@ -186,6 +252,7 @@ set_eventloop_tick(self, tick)
VALUE tick;
{
int ttick = NUM2INT(tick);
+ int thr_crit_bup;
rb_secure(4);
@@ -194,6 +261,9 @@ set_eventloop_tick(self, tick)
"timer-tick parameter must be 0 or positive number");
}
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
/* delete old timer callback */
Tk_DeleteTimerHandler(timer_token);
@@ -206,6 +276,8 @@ set_eventloop_tick(self, tick)
timer_token = (Tcl_TimerToken)NULL;
}
+ rb_thread_critical = thr_crit_bup;
+
return tick;
}
@@ -335,6 +407,39 @@ ip_get_eventloop_weight(self)
}
static VALUE
+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(divmod)->ptr[0]);
+ tcl_time.usec = NUM2LONG(RARRAY(divmod)->ptr[1]);
+ break;
+
+ case T_FLOAT:
+ /* time is second value */
+ divmod = rb_funcall(time, rb_intern("divmod"), 1, INT2FIX(1));
+ tcl_time.sec = NUM2LONG(RARRAY(divmod)->ptr[0]);
+ tcl_time.usec = (long)(NUM2DBL(RARRAY(divmod)->ptr[1]) * 1000000);
+
+ default:
+ rb_raise(rb_eArgError, "invalid value for time: '%s'",
+ RSTRING(rb_funcall(time, ID_inspect, 0, 0))->ptr);
+ }
+
+ Tcl_SetMaxBlockTime(&tcl_time);
+
+ return Qnil;
+}
+
+static VALUE
lib_evloop_abort_on_exc(self)
VALUE self;
{
@@ -361,7 +466,7 @@ lib_evloop_abort_on_exc_set(self, val)
rb_secure(4);
if (RTEST(val)) {
event_loop_abort_on_exc = 1;
- } else if (val == Qnil) {
+ } else if (NIL_P(val)) {
event_loop_abort_on_exc = -1;
} else {
event_loop_abort_on_exc = 0;
@@ -391,13 +496,19 @@ lib_num_of_mainwindows(self)
}
static int
-lib_eventloop_core(check_root, check_var)
+lib_eventloop_core(check_root, update_flag, check_var)
int check_root;
+ int update_flag;
int *check_var;
{
VALUE current = eventloop_thread;
int found_event = 1;
+ int event_flag;
struct timeval t;
+ int thr_crit_bup;
+
+
+ if (update_flag) DUMP1("update loop start!!");
t.tv_sec = (time_t)0;
t.tv_usec = (time_t)(no_event_wait*1000.0);
@@ -405,8 +516,11 @@ lib_eventloop_core(check_root, check_var)
Tk_DeleteTimerHandler(timer_token);
run_timer_flag = 0;
if (timer_tick > 0) {
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
timer_token = Tk_CreateTimerHandler(timer_tick, _timer_for_tcl,
(ClientData)0);
+ rb_thread_critical = thr_crit_bup;
} else {
timer_token = (Tcl_TimerToken)NULL;
}
@@ -416,7 +530,13 @@ lib_eventloop_core(check_root, check_var)
DUMP1("no other thread");
event_loop_wait_event = 0;
- if (timer_tick == 0) {
+ if (update_flag) {
+ event_flag = update_flag | TCL_DONT_WAIT; /* for safety */
+ } else {
+ event_flag = TCL_ALL_EVENTS;
+ }
+
+ if (timer_tick == 0 && update_flag == 0) {
timer_tick = NO_THREAD_INTERRUPT_TIME;
timer_token = Tk_CreateTimerHandler(timer_tick,
_timer_for_tcl,
@@ -429,25 +549,30 @@ lib_eventloop_core(check_root, check_var)
}
}
- found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS);
+ found_event = Tcl_DoOneEvent(event_flag);
- if (loop_counter++ > 30000) {
- loop_counter = 0;
+ if (update_flag != 0) {
+ if (found_event) {
+ DUMP1("next update loop");
+ continue;
+ } else {
+ DUMP1("update complete");
+ return 0;
+ }
}
- if (run_timer_flag) {
- /*
- DUMP1("timer interrupt");
+ DUMP1("check Root Widget");
+ if (check_root && Tk_GetNumMainWindows() == 0) {
run_timer_flag = 0;
- DUMP1("call rb_trap_exec()");
- rb_trap_exec();
- */
- DUMP1("check Root Widget");
- if (check_root && Tk_GetNumMainWindows() == 0) {
- run_timer_flag = 0;
- rb_trap_exec();
- return 1;
+ if (!rb_prohibit_interrupt) {
+ if (rb_trap_pending) rb_trap_exec();
}
+ return 1;
+ }
+
+ if (loop_counter++ > 30000) {
+ /* fprintf(stderr, "loop_counter > 30000\n"); */
+ loop_counter = 0;
}
} else {
@@ -458,6 +583,12 @@ lib_eventloop_core(check_root, check_var)
found_event = 1;
+ if (update_flag) {
+ event_flag = update_flag | TCL_DONT_WAIT; /* for safety */
+ } else {
+ event_flag = TCL_ALL_EVENTS | TCL_DONT_WAIT;
+ }
+
timer_tick = req_timer_tick;
tick_counter = 0;
while(tick_counter < event_loop_max) {
@@ -467,27 +598,40 @@ lib_eventloop_core(check_root, check_var)
}
}
- if (Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT)) {
+ if (Tcl_DoOneEvent(event_flag)) {
tick_counter++;
} else {
+ if (update_flag != 0) {
+ DUMP1("update complete");
+ return 0;
+ }
tick_counter += no_event_tick;
+ rb_thread_wait_for(t);
+ }
+
+ if (watchdog_thread != 0 && eventloop_thread != current) {
+ return 1;
+ }
- DUMP1("check Root Widget");
- if (check_root && Tk_GetNumMainWindows() == 0) {
- return 1;
+ DUMP1("check Root Widget");
+ if (check_root && Tk_GetNumMainWindows() == 0) {
+ run_timer_flag = 0;
+ if (!rb_prohibit_interrupt) {
+ if (rb_trap_pending) rb_trap_exec();
}
+ return 1;
+ }
- rb_thread_wait_for(t);
+ DUMP1("trap check");
+ if (!rb_prohibit_interrupt) {
+ if (rb_trap_pending) rb_trap_exec();
}
if (loop_counter++ > 30000) {
+ /* fprintf(stderr, "loop_counter > 30000\n"); */
loop_counter = 0;
}
- if (watchdog_thread != 0 && eventloop_thread != current) {
- return 1;
- }
-
if (run_timer_flag) {
/*
DUMP1("timer interrupt");
@@ -496,23 +640,11 @@ lib_eventloop_core(check_root, check_var)
break; /* switch to other thread */
}
}
-
- DUMP1("check Root Widget");
- if (check_root && Tk_GetNumMainWindows() == 0) {
- return 1;
- }
}
- /* rb_thread_schedule(); */
- if (run_timer_flag) {
- run_timer_flag = 0;
- rb_trap_exec();
- } else {
- DUMP1("thread scheduling");
- if (is_ruby_native_thread()) {
- rb_thread_schedule();
- }
- }
+ DUMP1("trap check & thread scheduling");
+ if (update_flag == 0) CHECK_INTS;
+
}
return 1;
}
@@ -523,7 +655,7 @@ lib_eventloop_main(check_rootwidget)
{
check_rootwidget_flag = RTEST(check_rootwidget);
- if (lib_eventloop_core(check_rootwidget_flag, (int *)NULL)) {
+ if (lib_eventloop_core(check_rootwidget_flag, 0, (int *)NULL)) {
return Qtrue;
} else {
return Qfalse;
@@ -614,8 +746,8 @@ lib_watchdog_core(check_rootwidget)
/* check other watchdog thread */
if (watchdog_thread != 0) {
- if (RTEST(rb_funcall(watchdog_thread, rb_intern("stop?"), 0))) {
- rb_funcall(watchdog_thread, rb_intern("kill"), 0);
+ if (RTEST(rb_funcall(watchdog_thread, ID_stop_p, 0))) {
+ rb_funcall(watchdog_thread, ID_kill, 0);
} else {
return Qnil;
}
@@ -626,7 +758,7 @@ lib_watchdog_core(check_rootwidget)
do {
if (eventloop_thread == 0
|| (loop_counter == prev_val
- && RTEST(rb_funcall(eventloop_thread, rb_intern("stop?"), 0))
+ && RTEST(rb_funcall(eventloop_thread, ID_stop_p, 0))
&& ++chance >= 3 )
) {
/* start new eventloop thread */
@@ -703,7 +835,7 @@ lib_do_one_event_core(argc, argv, self, is_ip)
VALUE self;
int is_ip;
{
- VALUE vflags;
+ volatile VALUE vflags;
int flags;
int found_event;
@@ -727,7 +859,8 @@ lib_do_one_event_core(argc, argv, self, is_ip)
}
}
- found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT);
+ /* found_event = Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT); */
+ found_event = Tcl_DoOneEvent(flags);
if (found_event) {
return Qtrue;
@@ -755,13 +888,97 @@ ip_do_one_event(argc, argv, self)
}
-/* Tcl command `ruby' */
+static void
+ip_set_exc_message(interp, exc)
+ Tcl_Interp *interp;
+ VALUE exc;
+{
+ char *buf;
+ Tcl_DString dstr;
+ volatile VALUE msg;
+ int thr_crit_bup;
+
+#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
+ volatile VALUE enc;
+ Tcl_Encoding encoding;
+#endif
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ msg = rb_funcall(exc, ID_message, 0, 0);
+
+#if TCL_MAJOR_VERSION > 8 || (TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION > 0)
+ enc = rb_ivar_get(exc, ID_at_enc);
+ if (NIL_P(enc)) {
+ enc = rb_ivar_get(msg, ID_at_enc);
+ }
+ if (NIL_P(enc)) {
+ encoding = (Tcl_Encoding)NULL;
+ } else if (TYPE(enc) == T_STRING) {
+ encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr);
+ } else {
+ enc = rb_funcall(enc, ID_to_s, 0, 0);
+ encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr);
+ }
+
+ /* to avoid a garbled error message dialog */
+ buf = ALLOC_N(char, (RSTRING(msg)->len)+1);
+ strncpy(buf, RSTRING(msg)->ptr, RSTRING(msg)->len);
+ buf[RSTRING(msg)->len] = 0;
+
+ Tcl_DStringInit(&dstr);
+ Tcl_DStringFree(&dstr);
+ Tcl_ExternalToUtfDString(encoding, buf, RSTRING(msg)->len, &dstr);
+
+ Tcl_AppendResult(interp, Tcl_DStringValue(&dstr), (char*)NULL);
+ DUMP2("error message:%s", Tcl_DStringValue(&dstr));
+ free(buf);
+
+#else /* TCL_VERSION <= 8.0 */
+ Tcl_AppendResult(interp, RSTRING(msg)->ptr, (char*)NULL);
+#endif
+
+ rb_thread_critical = thr_crit_bup;
+}
+
+static VALUE
+TkStringValue(obj)
+ VALUE obj;
+{
+ switch(TYPE(obj)) {
+ case T_STRING:
+ return obj;
+
+ case T_NIL:
+ return rb_str_new2("");
+
+ case T_TRUE:
+ return rb_str_new2("1");
+
+ case T_FALSE:
+ return rb_str_new2("0");
+
+ case T_ARRAY:
+ return rb_funcall(obj, ID_join, 1, rb_str_new2(" "));
+
+ default:
+ if (rb_respond_to(obj, ID_to_s)) {
+ return rb_funcall(obj, ID_to_s, 0, 0);
+ }
+ }
+
+ return rb_funcall(obj, ID_inspect, 0, 0);
+}
+
+/* Tcl command `ruby'|`ruby_eval' */
static VALUE
ip_ruby_eval_rescue(failed, einfo)
- VALUE *failed;
+ VALUE failed;
VALUE einfo;
{
- *failed = einfo;
+ DUMP1("call ip_ruby_eval_rescue");
+ RARRAY(failed)->ptr[0] = einfo;
return Qnil;
}
@@ -772,76 +989,265 @@ struct eval_body_arg {
static VALUE
ip_ruby_eval_body(arg)
- struct eval_body_arg *arg;
+ struct eval_body_arg *arg;
{
+ VALUE ret;
+ int status = 0;
+ int thr_crit_bup;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ DUMP1("call ip_ruby_eval_body");
rb_trap_immediate = 0;
- return rb_rescue2(rb_eval_string, (VALUE)arg->string,
- ip_ruby_eval_rescue, (VALUE)&(arg->failed),
+
+#if 0
+ ret = rb_rescue2(rb_eval_string, (VALUE)arg->string,
+ ip_ruby_eval_rescue, arg->failed,
rb_eStandardError, rb_eScriptError, rb_eSystemExit,
(VALUE)0);
+#else
+
+ ret = rb_eval_string_protect(arg->string, &status);
+ if (status) {
+ char *errtype, *buf;
+ int errtype_len, len;
+ VALUE old_gc;
+
+ old_gc = rb_gc_disable();
+
+ switch(status) {
+ case TAG_RETURN:
+ errtype = "LocalJumpError: ";
+ errtype_len = strlen(errtype);
+ len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len;
+ buf = ALLOC_N(char, len + 1);
+ strncpy(buf, errtype, errtype_len);
+ strncpy(buf + errtype_len,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->ptr,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->len);
+ *(buf + len) = 0;
+
+ RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackReturn, buf);
+ free(buf);
+ break;
+
+ case TAG_BREAK:
+ errtype = "LocalJumpError: ";
+ errtype_len = strlen(errtype);
+ len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len;
+ buf = ALLOC_N(char, len + 1);
+ strncpy(buf, errtype, errtype_len);
+ strncpy(buf + errtype_len,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->ptr,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->len);
+ *(buf + len) = 0;
+
+ RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackBreak, buf);
+ free(buf);
+ break;
+
+ case TAG_NEXT:
+ errtype = "LocalJumpError: ";
+ errtype_len = strlen(errtype);
+ len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len;
+ buf = ALLOC_N(char, len + 1);
+ strncpy(buf, errtype, errtype_len);
+ strncpy(buf + errtype_len,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->ptr,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->len);
+ *(buf + len) = 0;
+
+ RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackContinue,buf);
+ free(buf);
+ break;
+
+ case TAG_RETRY:
+ case TAG_REDO:
+ RARRAY(arg->failed)->ptr[0] = ruby_errinfo;
+ break;
+
+ case TAG_RAISE:
+ case TAG_FATAL:
+ RARRAY(arg->failed)->ptr[0] = ruby_errinfo;
+ break;
+
+ default:
+ buf = ALLOC_N(char, 256);
+ sprintf(buf, "unknown loncaljmp status %d", status);
+ RARRAY(arg->failed)->ptr[0] = rb_exc_new2(rb_eException, buf);
+ free(buf);
+ break;
+ }
+
+ if (old_gc == Qfalse) rb_gc_enable();
+
+ ret = Qnil;
+ }
+#endif
+
+ rb_thread_critical = thr_crit_bup;
+
+ return ret;
}
static VALUE
ip_ruby_eval_ensure(trapflag)
- VALUE trapflag;
+ VALUE trapflag;
{
rb_trap_immediate = NUM2INT(trapflag);
return Qnil;
}
+
static int
#if TCL_MAJOR_VERSION >= 8
-ip_ruby(clientData, interp, argc, argv)
+ip_ruby_eval(clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
Tcl_Obj *CONST argv[];
-#else
-ip_ruby(clientData, interp, argc, argv)
+#else /* TCL_MAJOR_VERSION < 8 */
+ip_ruby_eval(clientData, interp, argc, argv)
ClientData clientData;
Tcl_Interp *interp;
int argc;
char *argv[];
#endif
{
- VALUE res;
+ volatile VALUE res;
+ volatile VALUE exception = rb_ary_new2(1);
int old_trapflag;
- struct eval_body_arg arg;
- int dummy;
+ struct eval_body_arg *arg;
+ int thr_crit_bup;
/* ruby command has 1 arg. */
if (argc != 2) {
- rb_raise(rb_eArgError, "wrong number of arguments (%d for 1)", argc);
+ rb_raise(rb_eArgError, "wrong number of arguments (%d for 1)",
+ argc - 1);
}
+ /* allocate */
+ arg = ALLOC(struct eval_body_arg);
+
/* get C string from Tcl object */
#if TCL_MAJOR_VERSION >= 8
- arg.string = Tcl_GetStringFromObj(argv[1], &dummy);
-#else
- arg.string = argv[1];
+ {
+ char *str;
+ int len;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ str = Tcl_GetStringFromObj(argv[1], &len);
+ arg->string = ALLOC_N(char, len + 1);
+ strncpy(arg->string, str, len);
+ arg->string[len] = 0;
+
+ rb_thread_critical = thr_crit_bup;
+
+ }
+#else /* TCL_MAJOR_VERSION < 8 */
+ arg->string = argv[1];
#endif
- arg.failed = 0;
+ /* arg.failed = 0; */
+ RARRAY(exception)->ptr[0] = Qnil;
+ arg->failed = exception;
/* evaluate the argument string by ruby */
- DUMP2("rb_eval_string(%s)", arg.string);
+ DUMP2("rb_eval_string(%s)", arg->string);
old_trapflag = rb_trap_immediate;
- res = rb_ensure(ip_ruby_eval_body, (VALUE)&arg,
+#ifdef HAVE_NATIVETHREAD
+ if (!is_ruby_native_thread()) {
+ rb_bug("cross-thread violation on ip_ruby_eval()");
+ }
+#endif
+ res = rb_ensure(ip_ruby_eval_body, (VALUE)arg,
ip_ruby_eval_ensure, INT2FIX(old_trapflag));
+#if TCL_MAJOR_VERSION >= 8
+ free(arg->string);
+#endif
+
+ free(arg);
+
/* status check */
- if (arg.failed) {
- VALUE eclass = rb_obj_class(arg.failed);
+ /* if (arg.failed) { */
+ if (!NIL_P(RARRAY(exception)->ptr[0])) {
+ VALUE eclass;
+ volatile VALUE backtrace;
+
DUMP1("(rb_eval_string result) failed");
+
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, StringValuePtr(arg.failed), (char*)NULL);
- if (eclass == eTkCallbackBreak) {
+
+ res = RARRAY(exception)->ptr[0];
+ eclass = rb_obj_class(res);
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ DUMP1("set backtrace");
+ backtrace = rb_ary_join(rb_funcall(res, ID_backtrace, 0, 0),
+ rb_str_new2("\n"));
+ StringValue(backtrace);
+ Tcl_AddErrorInfo(interp, RSTRING(backtrace)->ptr);
+
+ rb_thread_critical = thr_crit_bup;
+
+ if (eclass == eTkCallbackReturn) {
+ return TCL_RETURN;
+
+ } else if (eclass == eTkCallbackBreak) {
return TCL_BREAK;
+
} else if (eclass == eTkCallbackContinue) {
return TCL_CONTINUE;
+
} else if (eclass == rb_eSystemExit) {
- Tcl_Eval(interp, "destroy .");
- rb_raise(rb_eSystemExit, StringValuePtr(arg.failed));
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ /* Tcl_Eval(interp, "destroy ."); */
+ if (Tk_GetNumMainWindows() > 0) {
+ Tk_Window main_win = Tk_MainWindow(interp);
+ if (main_win != (Tk_Window)NULL) {
+ Tk_DestroyWindow(main_win);
+ }
+ }
+
+ /* StringValue(res); */
+ res = rb_funcall(res, ID_message, 0, 0);
+
+ Tcl_AppendResult(interp, RSTRING(res)->ptr, (char*)NULL);
+
+ rb_thread_critical = thr_crit_bup;
+
+ rb_raise(rb_eSystemExit, RSTRING(res)->ptr);
+
+ } else if (rb_obj_is_kind_of(res, eLocalJumpError)) {
+ VALUE reason = rb_ivar_get(res, ID_at_reason);
+
+ if (TYPE(reason) != T_SYMBOL) {
+ ip_set_exc_message(interp, res);
+ return TCL_ERROR;
+ }
+
+ if (SYM2ID(reason) == ID_return) {
+ return TCL_RETURN;
+
+ } else if (SYM2ID(reason) == ID_break) {
+ return TCL_BREAK;
+
+ } else if (SYM2ID(reason) == ID_next) {
+ return TCL_CONTINUE;
+
+ } else {
+ ip_set_exc_message(interp, res);
+ return TCL_ERROR;
+ }
} else {
+ ip_set_exc_message(interp, res);
return TCL_ERROR;
}
}
@@ -854,11 +1260,390 @@ ip_ruby(clientData, interp, argc, argv)
}
/* copy result to the tcl interpreter */
- DUMP2("(rb_eval_string result) %s", StringValuePtr(res));
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ res = TkStringValue(res);
+ DUMP2("(rb_eval_string result) %s", RSTRING(res)->ptr);
+ DUMP1("Tcl_AppendResult");
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, RSTRING(res)->ptr, (char *)NULL);
+
+ rb_thread_critical = thr_crit_bup;
+
+ return TCL_OK;
+}
+
+
+/* Tcl command `ruby_cmd' */
+struct cmd_body_arg {
+ VALUE receiver;
+ ID method;
+ VALUE args;
+ VALUE failed;
+};
+
+static VALUE
+ip_ruby_cmd_core(arg)
+ struct cmd_body_arg *arg;
+{
+ VALUE ret;
+
+ DUMP1("call ip_ruby_cmd_core");
+ ret = rb_apply(arg->receiver, arg->method, arg->args);
+ DUMP1("finish ip_ruby_cmd_core");
+
+ return ret;
+}
+
+static VALUE
+ip_ruby_cmd_rescue(failed, einfo)
+ VALUE failed;
+ VALUE einfo;
+{
+ DUMP1("call ip_ruby_cmd_rescue");
+ RARRAY(failed)->ptr[0] = einfo;
+ return Qnil;
+}
+
+static VALUE
+ip_ruby_cmd_body(arg)
+ struct cmd_body_arg *arg;
+{
+ VALUE ret;
+ int status = 0;
+ int thr_crit_bup;
+ VALUE old_gc;
+
+ volatile VALUE receiver = arg->receiver;
+ volatile VALUE args = arg->args;
+ volatile VALUE failed = arg->failed;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ DUMP1("call ip_ruby_cmd_body");
+ rb_trap_immediate = 0;
+
+#if 0
+ ret = rb_rescue2(ip_ruby_cmd_core, (VALUE)arg,
+ ip_ruby_cmd_rescue, arg->failed,
+ rb_eStandardError, rb_eScriptError, rb_eSystemExit,
+ (VALUE)0);
+#else
+ ret = rb_protect(ip_ruby_cmd_core, (VALUE)arg, &status);
+
+ if (status) {
+ char *errtype, *buf;
+ int errtype_len, len;
+
+ old_gc = rb_gc_disable();
+
+ switch(status) {
+ case TAG_RETURN:
+ errtype = "LocalJumpError: ";
+ errtype_len = strlen(errtype);
+ len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len;
+ buf = ALLOC_N(char, len + 1);
+ strncpy(buf, errtype, errtype_len);
+ strncpy(buf + errtype_len,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->ptr,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->len);
+ *(buf + len) = 0;
+
+ RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackReturn, buf);
+ free(buf);
+ break;
+
+ case TAG_BREAK:
+ errtype = "LocalJumpError: ";
+ errtype_len = strlen(errtype);
+ len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len;
+ buf = ALLOC_N(char, len + 1);
+ strncpy(buf, errtype, errtype_len);
+ strncpy(buf + errtype_len,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->ptr,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->len);
+ *(buf + len) = 0;
+
+ RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackBreak, buf);
+ free(buf);
+ break;
+
+ case TAG_NEXT:
+ errtype = "LocalJumpError: ";
+ errtype_len = strlen(errtype);
+ len = errtype_len + RSTRING(rb_obj_as_string(ruby_errinfo))->len;
+ buf = ALLOC_N(char, len + 1);
+ strncpy(buf, errtype, errtype_len);
+ strncpy(buf + errtype_len,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->ptr,
+ RSTRING(rb_obj_as_string(ruby_errinfo))->len);
+ *(buf + len) = 0;
+
+ RARRAY(arg->failed)->ptr[0] = rb_exc_new2(eTkCallbackContinue,buf);
+ free(buf);
+ break;
+
+ case TAG_RETRY:
+ case TAG_REDO:
+ RARRAY(arg->failed)->ptr[0] = ruby_errinfo;
+ break;
+
+ case TAG_RAISE:
+ case TAG_FATAL:
+ RARRAY(arg->failed)->ptr[0] = ruby_errinfo;
+ break;
+
+ default:
+ buf = ALLOC_N(char, 256);
+ rb_warn(buf, "unknown loncaljmp status %d", status);
+ RARRAY(arg->failed)->ptr[0] = rb_exc_new2(rb_eException, buf);
+ free(buf);
+ break;
+ }
+
+ if (old_gc == Qfalse) rb_gc_enable();
+
+ ret = Qnil;
+ }
+#endif
+
+ rb_thread_critical = thr_crit_bup;
+ DUMP1("finish ip_ruby_cmd_body");
+
+ return ret;
+}
+
+static VALUE
+ip_ruby_cmd_ensure(trapflag)
+ VALUE trapflag;
+{
+ rb_trap_immediate = NUM2INT(trapflag);
+ return Qnil;
+}
+
+/* ruby_cmd receiver method arg ... */
+static int
+#if TCL_MAJOR_VERSION >= 8
+ip_ruby_cmd(clientData, interp, argc, argv)
+ ClientData clientData;
+ Tcl_Interp *interp;
+ int argc;
+ Tcl_Obj *CONST argv[];
+#else /* TCL_MAJOR_VERSION < 8 */
+ip_ruby_cmd(clientData, interp, argc, argv)
+ ClientData clientData;
+ Tcl_Interp *interp;
+ int argc;
+ char *argv[];
+#endif
+{
+ volatile VALUE res;
+ volatile VALUE receiver;
+ volatile ID method;
+ volatile VALUE args = rb_ary_new2(argc - 2);
+ volatile VALUE exception = rb_ary_new2(1);
+ char *str;
+ int i;
+ int len;
+ int old_trapflag;
+ struct cmd_body_arg *arg;
+ int thr_crit_bup;
+ VALUE old_gc;
+
+ if (argc < 3) {
+ rb_raise(rb_eArgError, "too few arguments");
+ }
+
+ /* allocate */
+ arg = ALLOC(struct cmd_body_arg);
+
+ /* 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);
+ if (str[0] == ':' || ('A' <= str[0] && str[0] <= 'Z')) {
+ /* class | module | constant */
+ receiver = rb_const_get(rb_cObject, rb_intern(str));
+ } else if (str[0] == '$') {
+ /* global variable */
+ receiver = rb_gv_get(str);
+ } else {
+ /* global variable omitted '$' */
+ char *buf;
+
+ len = strlen(str);
+ buf = ALLOC_N(char, len + 2);
+ buf[0] = '$';
+ strncpy(buf + 1, str, len);
+ buf[len + 1] = 0;
+ receiver = rb_gv_get(buf);
+ free(buf);
+ }
+ if (NIL_P(receiver)) {
+ rb_raise(rb_eArgError, "unknown class/module/global-variable '%s'",
+ str);
+ }
+
+ /* 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 */
+ RARRAY(args)->len = 0;
+ for(i = 3; i < argc; i++) {
+#if TCL_MAJOR_VERSION >= 8
+ str = Tcl_GetStringFromObj(argv[i], &len);
+ DUMP2("arg:%s",str);
+ RARRAY(args)->ptr[RARRAY(args)->len++] = rb_tainted_str_new(str, len);
+#else /* TCL_MAJOR_VERSION < 8 */
+ DUMP2("arg:%s",argv[i]);
+ RARRAY(args)->ptr[RARRAY(args)->len++] = rb_tainted_str_new2(argv[i]);
+#endif
+ }
+
+ if (old_gc == Qfalse) rb_gc_enable();
+ rb_thread_critical = thr_crit_bup;
+
+ RARRAY(exception)->ptr[0] = Qnil;
+
+ arg->receiver = receiver;
+ arg->method = method;
+ arg->args = args;
+ arg->failed = exception;
+
+ /* evaluate the argument string by ruby */
+ old_trapflag = rb_trap_immediate;
+#ifdef HAVE_NATIVETHREAD
+ if (!is_ruby_native_thread()) {
+ rb_bug("cross-thread violation on ip_ruby_cmd()");
+ }
+#endif
+
+ res = rb_ensure(ip_ruby_cmd_body, (VALUE)arg,
+ ip_ruby_cmd_ensure, INT2FIX(old_trapflag));
+
+ free(arg);
+
+ /* status check */
+ /* if (arg.failed) { */
+ if (!NIL_P(RARRAY(exception)->ptr[0])) {
+ VALUE eclass;
+ volatile VALUE backtrace;
+
+ DUMP1("(rb_eval_cmd result) failed");
+
+ Tcl_ResetResult(interp);
+
+ res = RARRAY(exception)->ptr[0];
+ eclass = rb_obj_class(res);
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ DUMP1("set backtrace");
+ backtrace = rb_ary_join(rb_funcall(res, ID_backtrace, 0, 0),
+ rb_str_new2("\n"));
+ StringValue(backtrace);
+ Tcl_AddErrorInfo(interp, RSTRING(backtrace)->ptr);
+
+ rb_thread_critical = thr_crit_bup;
+
+ if (eclass == eTkCallbackReturn) {
+ return TCL_RETURN;
+
+ } else if (eclass == eTkCallbackBreak) {
+ return TCL_BREAK;
+
+ } else if (eclass == eTkCallbackContinue) {
+ return TCL_CONTINUE;
+
+ } else if (eclass == rb_eSystemExit) {
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ /* Tcl_Eval(interp, "destroy ."); */
+ if (Tk_GetNumMainWindows() > 0) {
+ Tk_Window main_win = Tk_MainWindow(interp);
+ if (main_win != (Tk_Window)NULL) {
+ Tk_DestroyWindow(main_win);
+ }
+ }
+
+ /* StringValue(res); */
+ res = rb_funcall(res, ID_message, 0, 0);
+
+ Tcl_AppendResult(interp, RSTRING(res)->ptr, (char*)NULL);
+
+ rb_thread_critical = thr_crit_bup;
+
+ rb_raise(rb_eSystemExit, RSTRING(res)->ptr);
+ } else if (rb_obj_is_kind_of(res, eLocalJumpError)) {
+ VALUE reason = rb_ivar_get(res, ID_at_reason);
+
+ if (TYPE(reason) != T_SYMBOL) {
+ ip_set_exc_message(interp, res);
+ return TCL_ERROR;
+ }
+
+ if (SYM2ID(reason) == ID_return) {
+ return TCL_RETURN;
+
+ } else if (SYM2ID(reason) == ID_break) {
+ return TCL_BREAK;
+
+ } else if (SYM2ID(reason) == ID_next) {
+ return TCL_CONTINUE;
+
+ } else {
+ ip_set_exc_message(interp, res);
+ return TCL_ERROR;
+ }
+ } else {
+ ip_set_exc_message(interp, res);
+ return TCL_ERROR;
+ }
+ }
+
+ /* result must be string or nil */
+ if (NIL_P(res)) {
+ DUMP1("(rb_eval_cmd result) nil");
+ Tcl_ResetResult(interp);
+ return TCL_OK;
+ }
+
+
+ /* copy result to the tcl interpreter */
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+
+ old_gc = rb_gc_disable();
+
+ res = TkStringValue(res);
+
+ if (old_gc == Qfalse) rb_gc_enable();
+ DUMP2("(rb_eval_cmd result) '%s'", RSTRING(res)->ptr);
DUMP1("Tcl_AppendResult");
Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, StringValuePtr(res), (char *)NULL);
+ Tcl_AppendResult(interp, RSTRING(res)->ptr, (char *)NULL);
+
+ rb_thread_critical = thr_crit_bup;
+ DUMP1("end of ip_ruby_cmd");
return TCL_OK;
}
@@ -866,8 +1651,236 @@ ip_ruby(clientData, interp, argc, argv)
/**************************/
/* based on tclEvent.c */
/**************************/
-static char *VwaitVarProc _((ClientData, Tcl_Interp *, CONST84 char *,
- CONST84 char *, int));
+
+#if 0 /*
+ Disable the following "update" and "thread_update". Bcause,
+ they don't work in a callback-proc. After calling update in
+ a callback-proc, the callback proc never be worked.
+ If the problem will be fixed in the future, may enable the
+ functions.
+ */
+/*********************/
+/* replace of update */
+/*********************/
+#if TCL_MAJOR_VERSION >= 8
+static int ip_rbUpdateObjCmd _((ClientData, Tcl_Interp *, int,
+ Tcl_Obj *CONST []));
+static int
+ip_rbUpdateObjCmd(clientData, interp, objc, objv)
+ ClientData clientData;
+ Tcl_Interp *interp;
+ int objc;
+ Tcl_Obj *CONST objv[];
+#else /* TCL_MAJOR_VERSION < 8 */
+static int ip_rbUpdateCommand _((ClientData, Tcl_Interp *, int, char *[]));
+static int
+ip_rbUpdateCommand(clientData, interp, objc, objv)
+ ClientData clientData;
+ Tcl_Interp *interp;
+ int objc;
+ char *objv[];
+#endif
+{
+ int optionIndex;
+ int ret, done;
+ int flags = 0;
+ static CONST char *updateOptions[] = {"idletasks", (char *) NULL};
+ enum updateOptions {REGEXP_IDLETASKS};
+ char *nameString;
+ int dummy;
+
+ DUMP1("Ruby's 'update' is called");
+ if (objc == 1) {
+ flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
+
+ } else if (objc == 2) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
+ "option", 0, &optionIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum updateOptions) optionIndex) {
+ case REGEXP_IDLETASKS: {
+ flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
+ break;
+ }
+ default: {
+ Tcl_Panic("ip_rbUpdateObjCmd: bad option index to UpdateOptions");
+ }
+ }
+ } else {
+#ifdef Tcl_WrongNumArgs
+ Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]");
+#else
+# if TCL_MAJOR_VERSION >= 8
+ Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
+ Tcl_GetStringFromObj(objv[0], &dummy),
+ " [ idletasks ]\"",
+ (char *) NULL);
+# else /* TCL_MAJOR_VERSION < 8 */
+ Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
+ objv[0], " [ idletasks ]\"", (char *) NULL);
+# endif
+#endif
+ return TCL_ERROR;
+ }
+
+ /* call eventloop */
+#if 1
+ ret = lib_eventloop_core(0, flags, (int *)NULL); /* ignore result */
+#else
+ Tcl_UpdateObjCmd(clientData, interp, objc, objv);
+#endif
+
+ /*
+ * Must clear the interpreter's result because event handlers could
+ * have executed commands.
+ */
+
+ DUMP2("last result '%s'", Tcl_GetStringResult(interp));
+ Tcl_ResetResult(interp);
+ DUMP1("finish Ruby's 'update'");
+ return TCL_OK;
+}
+
+
+/**********************/
+/* update with thread */
+/**********************/
+struct th_update_param {
+ VALUE thread;
+ int done;
+};
+
+static void rb_threadUpdateProc _((ClientData));
+static void
+rb_threadUpdateProc(clientData)
+ ClientData clientData; /* Pointer to integer to set to 1. */
+{
+ struct th_update_param *param = (struct th_update_param *) clientData;
+
+ DUMP1("threadUpdateProc is called");
+ param->done = 1;
+ rb_thread_run(param->thread);
+
+ return;
+}
+
+#if TCL_MAJOR_VERSION >= 8
+static int ip_rb_threadUpdateObjCmd _((ClientData, Tcl_Interp *, int,
+ Tcl_Obj *CONST []));
+static int
+ip_rb_threadUpdateObjCmd(clientData, interp, objc, objv)
+ ClientData clientData;
+ Tcl_Interp *interp;
+ int objc;
+ Tcl_Obj *CONST objv[];
+#else /* TCL_MAJOR_VERSION < 8 */
+static int ip_rb_threadUpdateCommand _((ClientData, Tcl_Interp *, int,
+ char *[]));
+static int
+ip_rb_threadUpdateCommand(clientData, interp, objc, objv)
+ ClientData clientData;
+ Tcl_Interp *interp;
+ int objc;
+ char *objv[];
+#endif
+{
+ int optionIndex;
+ int ret, done;
+ int flags = 0;
+ int dummy;
+ struct th_update_param *param;
+ static CONST char *updateOptions[] = {"idletasks", (char *) NULL};
+ enum updateOptions {REGEXP_IDLETASKS};
+ volatile VALUE current_thread = rb_thread_current();
+
+ DUMP1("Ruby's 'thread_update' is called");
+
+ if (rb_thread_alone() || eventloop_thread == current_thread) {
+#define USE_TCL_UPDATE 0
+#if TCL_MAJOR_VERSION >= 8
+# if USE_TCL_UPDATE
+ DUMP1("call Tcl_UpdateObjCmd");
+ return Tcl_UpdateObjCmd(clientData, interp, objc, objv);
+# else
+ DUMP1("call ip_rbUpdateObjCmd");
+ return ip_rbUpdateObjCmd(clientData, interp, objc, objv);
+# endif
+#else /* TCL_MAJOR_VERSION < 8 */
+# if USE_TCL_UPDATE
+ DUMP1("call ip_rbUpdateCommand");
+ return Tcl_UpdateCommand(clientData, interp, objc, objv);
+# else
+ DUMP1("call ip_rbUpdateCommand");
+ return ip_rbUpdateCommand(clientData, interp, objc, objv);
+# endif
+#endif
+ }
+
+ DUMP1("start Ruby's 'thread_update' body");
+
+ if (objc == 1) {
+ flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
+
+ } else if (objc == 2) {
+ if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions,
+ "option", 0, &optionIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch ((enum updateOptions) optionIndex) {
+ case REGEXP_IDLETASKS: {
+ flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
+ break;
+ }
+ default: {
+ Tcl_Panic("ip_rb_threadUpdateObjCmd: bad option index to UpdateOptions");
+ }
+ }
+ } else {
+#ifdef Tcl_WrongNumArgs
+ Tcl_WrongNumArgs(interp, 1, objv, "[ idletasks ]");
+#else
+# if TCL_MAJOR_VERSION >= 8
+ Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
+ Tcl_GetStringFromObj(objv[0], &dummy),
+ " [ idletasks ]\"",
+ (char *) NULL);
+# else /* TCL_MAJOR_VERSION < 8 */
+ Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
+ objv[0], " [ idletasks ]\"", (char *) NULL);
+# endif
+#endif
+ return TCL_ERROR;
+ }
+
+ DUMP1("pass argument check");
+
+ param = (struct th_update_param *)Tcl_Alloc(sizeof(struct th_update_param));
+ param->thread = current_thread;
+ param->done = 0;
+
+ DUMP1("set idle proc");
+ Tcl_DoWhenIdle(rb_threadUpdateProc, (ClientData) param);
+
+ while(!param->done) {
+ DUMP1("wait for complete idle proc");
+ rb_thread_stop();
+ }
+
+ Tcl_Free((char *)param);
+
+ DUMP1("finish Ruby's 'thread_update'");
+ return TCL_OK;
+}
+#endif /* update and thread_update don't work internal callback proc */
+
+
+/***************************/
+/* replace of vwait/tkwait */
+/***************************/
+#if TCL_MAJOR_VERSION >= 8
+static char *VwaitVarProc _((ClientData, Tcl_Interp *,
+ CONST84 char *,CONST84 char *, int));
static char *
VwaitVarProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Pointer to integer to set to 1. */
@@ -875,6 +1888,16 @@ VwaitVarProc(clientData, interp, name1, name2, flags)
CONST84 char *name1; /* Name of variable. */
CONST84 char *name2; /* Second part of variable name. */
int flags; /* Information about what happened. */
+#else /* TCL_MAJOR_VERSION < 8 */
+static char *VwaitVarProc _((ClientData, Tcl_Interp *, char *, char *, int));
+static char *
+VwaitVarProc(clientData, interp, name1, name2, flags)
+ ClientData clientData; /* Pointer to integer to set to 1. */
+ Tcl_Interp *interp; /* Interpreter containing variable. */
+ char *name1; /* Name of variable. */
+ char *name2; /* Second part of variable name. */
+ int flags; /* Information about what happened. */
+#endif
{
int *donePtr = (int *) clientData;
@@ -891,7 +1914,7 @@ ip_rbVwaitObjCmd(clientData, interp, objc, objv)
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
-#else
+#else /* TCL_MAJOR_VERSION < 8 */
static int ip_rbVwaitCommand _((ClientData, Tcl_Interp *, int, char *[]));
static int
ip_rbVwaitCommand(clientData, interp, objc, objv)
@@ -901,44 +1924,71 @@ ip_rbVwaitCommand(clientData, interp, objc, objv)
char *objv[];
#endif
{
- int done, foundEvent;
+ int ret, done, foundEvent;
char *nameString;
int dummy;
+ int thr_crit_bup;
DUMP1("Ruby's 'vwait' is called");
if (objc != 2) {
#ifdef Tcl_WrongNumArgs
Tcl_WrongNumArgs(interp, 1, objv, "name");
#else
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
#if TCL_MAJOR_VERSION >= 8
/* nameString = Tcl_GetString(objv[0]); */
nameString = Tcl_GetStringFromObj(objv[0], &dummy);
-#else
+#else /* TCL_MAJOR_VERSION < 8 */
nameString = objv[0];
#endif
- Tcl_AppendResult(interp, "wrong # args: should be \"",
+ Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
nameString, " name\"", (char *) NULL);
+
+ rb_thread_critical = thr_crit_bup;
#endif
return TCL_ERROR;
}
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
#if TCL_MAJOR_VERSION >= 8
/* nameString = Tcl_GetString(objv[1]); */
nameString = Tcl_GetStringFromObj(objv[1], &dummy);
-#else
+#else /* TCL_MAJOR_VERSION < 8 */
nameString = objv[1];
#endif
+ /*
if (Tcl_TraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, (ClientData) &done) != TCL_OK) {
return TCL_ERROR;
- };
+ }
+ */
+ ret = Tcl_TraceVar(interp, nameString,
+ TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ VwaitVarProc, (ClientData) &done);
+
+ rb_thread_critical = thr_crit_bup;
+
+ if (ret != TCL_OK) {
+ return TCL_ERROR;
+ }
done = 0;
- foundEvent = lib_eventloop_core(/* not check root-widget */0, &done);
+ foundEvent = lib_eventloop_core(/* not check root-widget */0, 0, &done);
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
Tcl_UntraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
VwaitVarProc, (ClientData) &done);
+ rb_thread_critical = thr_crit_bup;
+
/*
* Clear out the interpreter's result, since it may have been set
* by event handlers.
@@ -946,8 +1996,14 @@ ip_rbVwaitCommand(clientData, interp, objc, objv)
Tcl_ResetResult(interp);
if (!foundEvent) {
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
Tcl_AppendResult(interp, "can't wait for variable \"", nameString,
"\": would wait forever", (char *) NULL);
+
+ rb_thread_critical = thr_crit_bup;
+
return TCL_ERROR;
}
return TCL_OK;
@@ -957,8 +2013,9 @@ ip_rbVwaitCommand(clientData, interp, objc, objv)
/**************************/
/* based on tkCmd.c */
/**************************/
-static char *WaitVariableProc _((ClientData, Tcl_Interp *, CONST84 char *,
- CONST84 char *, int));
+#if TCL_MAJOR_VERSION >= 8
+static char *WaitVariableProc _((ClientData, Tcl_Interp *,
+ CONST84 char *,CONST84 char *, int));
static char *
WaitVariableProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Pointer to integer to set to 1. */
@@ -966,6 +2023,17 @@ WaitVariableProc(clientData, interp, name1, name2, flags)
CONST84 char *name1; /* Name of variable. */
CONST84 char *name2; /* Second part of variable name. */
int flags; /* Information about what happened. */
+#else /* TCL_MAJOR_VERSION < 8 */
+static char *WaitVariableProc _((ClientData, Tcl_Interp *,
+ char *, char *, int));
+static char *
+WaitVariableProc(clientData, interp, name1, name2, flags)
+ ClientData clientData; /* Pointer to integer to set to 1. */
+ Tcl_Interp *interp; /* Interpreter containing variable. */
+ char *name1; /* Name of variable. */
+ char *name2; /* Second part of variable name. */
+ int flags; /* Information about what happened. */
+#endif
{
int *donePtr = (int *) clientData;
@@ -1011,7 +2079,7 @@ ip_rbTkWaitObjCmd(clientData, interp, objc, objv)
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
-#else
+#else /* TCL_MAJOR_VERSION < 8 */
static int ip_rbTkWaitCommand _((ClientData, Tcl_Interp *, int, char *[]));
static int
ip_rbTkWaitCommand(clientData, interp, objc, objv)
@@ -1027,7 +2095,8 @@ ip_rbTkWaitCommand(clientData, interp, objc, objv)
(char *) NULL };
enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW };
char *nameString;
- int dummy;
+ int ret, dummy;
+ int thr_crit_bup;
DUMP1("Ruby's 'tkwait' is called");
@@ -1035,27 +2104,46 @@ ip_rbTkWaitCommand(clientData, interp, objc, objv)
#ifdef Tcl_WrongNumArgs
Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name");
#else
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
#if TCL_MAJOR_VERSION >= 8
- Tcl_AppendResult(interp, "wrong # args: should be \"",
+ Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
Tcl_GetStringFromObj(objv[0], &dummy),
" variable|visibility|window name\"",
(char *) NULL);
-#else
- Tcl_AppendResult(interp, "wrong # args: should be \"",
+#else /* TCL_MAJOR_VERSION < 8 */
+ Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
objv[0], " variable|visibility|window name\"",
(char *) NULL);
#endif
+
+ rb_thread_critical = thr_crit_bup;
#endif
return TCL_ERROR;
}
#if TCL_MAJOR_VERSION >= 8
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ /*
if (Tcl_GetIndexFromObj(interp, objv[1],
(CONST84 char **)optionStrings,
"option", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
-#else
+ */
+ ret = Tcl_GetIndexFromObj(interp, objv[1],
+ (CONST84 char **)optionStrings,
+ "option", 0, &index);
+
+ rb_thread_critical = thr_crit_bup;
+
+ if (ret != TCL_OK) {
+ return TCL_ERROR;
+ }
+#else /* TCL_MAJOR_VERSION < 8 */
{
int c = objv[1][0];
size_t length = strlen(objv[1]);
@@ -1077,69 +2165,122 @@ ip_rbTkWaitCommand(clientData, interp, objc, objv)
}
#endif
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
#if TCL_MAJOR_VERSION >= 8
/* nameString = Tcl_GetString(objv[2]); */
nameString = Tcl_GetStringFromObj(objv[2], &dummy);
-#else
+#else /* TCL_MAJOR_VERSION < 8 */
nameString = objv[2];
#endif
+ rb_thread_critical = thr_crit_bup;
+
switch ((enum options) index) {
case TKWAIT_VARIABLE: {
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+ /*
if (Tcl_TraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
WaitVariableProc, (ClientData) &done) != TCL_OK) {
return TCL_ERROR;
}
+ */
+ ret = Tcl_TraceVar(interp, nameString,
+ TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ WaitVariableProc, (ClientData) &done);
+
+ rb_thread_critical = thr_crit_bup;
+
+ if (ret != TCL_OK) {
+ return TCL_ERROR;
+ }
done = 0;
- lib_eventloop_core(check_rootwidget_flag, &done);
+ lib_eventloop_core(check_rootwidget_flag, 0, &done);
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
Tcl_UntraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
WaitVariableProc, (ClientData) &done);
+
+ rb_thread_critical = thr_crit_bup;
+
break;
}
case TKWAIT_VISIBILITY: {
Tk_Window window;
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
window = Tk_NameToWindow(interp, nameString, tkwin);
if (window == NULL) {
+ rb_thread_critical = thr_crit_bup;
return TCL_ERROR;
}
+
Tk_CreateEventHandler(window,
VisibilityChangeMask|StructureNotifyMask,
WaitVisibilityProc, (ClientData) &done);
+
+ rb_thread_critical = thr_crit_bup;
+
done = 0;
- lib_eventloop_core(check_rootwidget_flag, &done);
+ lib_eventloop_core(check_rootwidget_flag, 0, &done);
if (done != 1) {
/*
* Note that we do not delete the event handler because it
* was deleted automatically when the window was destroyed.
*/
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "window \"", nameString,
"\" was deleted before its visibility changed",
(char *) NULL);
+
+ rb_thread_critical = thr_crit_bup;
+
return TCL_ERROR;
}
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
Tk_DeleteEventHandler(window,
VisibilityChangeMask|StructureNotifyMask,
WaitVisibilityProc, (ClientData) &done);
+
+ rb_thread_critical = thr_crit_bup;
+
break;
}
case TKWAIT_WINDOW: {
Tk_Window window;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
window = Tk_NameToWindow(interp, nameString, tkwin);
if (window == NULL) {
+ rb_thread_critical = thr_crit_bup;
return TCL_ERROR;
}
+
Tk_CreateEventHandler(window, StructureNotifyMask,
WaitWindowProc, (ClientData) &done);
+
+ rb_thread_critical = thr_crit_bup;
+
done = 0;
- lib_eventloop_core(check_rootwidget_flag, &done);
+ lib_eventloop_core(check_rootwidget_flag, 0, &done);
/*
* Note: there's no need to delete the event handler. It was
* deleted automatically when the window was destroyed.
@@ -1165,8 +2306,9 @@ struct th_vwait_param {
int done;
};
-static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *, CONST84 char *,
- CONST84 char *, int));
+#if TCL_MAJOR_VERSION >= 8
+static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *,
+ CONST84 char *,CONST84 char *, int));
static char *
rb_threadVwaitProc(clientData, interp, name1, name2, flags)
ClientData clientData; /* Pointer to integer to set to 1. */
@@ -1174,6 +2316,17 @@ rb_threadVwaitProc(clientData, interp, name1, name2, flags)
CONST84 char *name1; /* Name of variable. */
CONST84 char *name2; /* Second part of variable name. */
int flags; /* Information about what happened. */
+#else /* TCL_MAJOR_VERSION < 8 */
+static char *rb_threadVwaitProc _((ClientData, Tcl_Interp *,
+ char *, char *, int));
+static char *
+rb_threadVwaitProc(clientData, interp, name1, name2, flags)
+ ClientData clientData; /* Pointer to integer to set to 1. */
+ Tcl_Interp *interp; /* Interpreter containing variable. */
+ char *name1; /* Name of variable. */
+ char *name2; /* Second part of variable name. */
+ int flags; /* Information about what happened. */
+#endif
{
struct th_vwait_param *param = (struct th_vwait_param *) clientData;
@@ -1197,6 +2350,7 @@ rb_threadWaitVisibilityProc(clientData, eventPtr)
if (eventPtr->type == DestroyNotify) {
param->done = 2;
}
+ rb_thread_run(param->thread);
}
static void rb_threadWaitWindowProc _((ClientData, XEvent *));
@@ -1210,6 +2364,7 @@ rb_threadWaitWindowProc(clientData, eventPtr)
if (eventPtr->type == DestroyNotify) {
param->done = 1;
}
+ rb_thread_run(param->thread);
}
#if TCL_MAJOR_VERSION >= 8
@@ -1221,7 +2376,7 @@ ip_rb_threadVwaitObjCmd(clientData, interp, objc, objv)
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
-#else
+#else /* TCL_MAJOR_VERSION < 8 */
static int ip_rb_threadVwaitCommand _((ClientData, Tcl_Interp *, int,
char *[]));
static int
@@ -1234,15 +2389,17 @@ ip_rb_threadVwaitCommand(clientData, interp, objc, objv)
{
struct th_vwait_param *param;
char *nameString;
- int dummy;
+ int ret, dummy;
+ int thr_crit_bup;
+ volatile VALUE current_thread = rb_thread_current();
DUMP1("Ruby's 'thread_vwait' is called");
- if (eventloop_thread == rb_thread_current()) {
+ if (rb_thread_alone() || eventloop_thread == current_thread) {
#if TCL_MAJOR_VERSION >= 8
DUMP1("call ip_rbVwaitObjCmd");
return ip_rbVwaitObjCmd(clientData, interp, objc, objv);
-#else
+#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("call ip_rbVwaitCommand");
return ip_rbVwaitCommand(clientData, interp, objc, objv);
#endif
@@ -1252,44 +2409,69 @@ ip_rb_threadVwaitCommand(clientData, interp, objc, objv)
#ifdef Tcl_WrongNumArgs
Tcl_WrongNumArgs(interp, 1, objv, "name");
#else
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
#if TCL_MAJOR_VERSION >= 8
/* nameString = Tcl_GetString(objv[0]); */
nameString = Tcl_GetStringFromObj(objv[0], &dummy);
-#else
+#else /* TCL_MAJOR_VERSION < 8 */
nameString = objv[0];
#endif
- Tcl_AppendResult(interp, "wrong # args: should be \"",
+ Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
nameString, " name\"", (char *) NULL);
+
+ rb_thread_critical = thr_crit_bup;
#endif
return TCL_ERROR;
}
#if TCL_MAJOR_VERSION >= 8
/* nameString = Tcl_GetString(objv[1]); */
nameString = Tcl_GetStringFromObj(objv[1], &dummy);
-#else
+#else /* TCL_MAJOR_VERSION < 8 */
nameString = objv[1];
#endif
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param));
- param->thread = rb_thread_current();
+ param->thread = current_thread;
param->done = 0;
+ /*
if (Tcl_TraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
rb_threadVwaitProc, (ClientData) param) != TCL_OK) {
return TCL_ERROR;
- };
+ }
+ */
+ ret = Tcl_TraceVar(interp, nameString,
+ TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ rb_threadVwaitProc, (ClientData) param);
+
+ rb_thread_critical = thr_crit_bup;
+
+ if (ret != TCL_OK) {
+ return TCL_ERROR;
+ }
- if (!param->done) {
+ /* if (!param->done) { */
+ while(!param->done) {
rb_thread_stop();
}
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
Tcl_UntraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
rb_threadVwaitProc, (ClientData) param);
Tcl_Free((char *)param);
+ rb_thread_critical = thr_crit_bup;
+
return TCL_OK;
}
@@ -1302,7 +2484,7 @@ ip_rb_threadTkWaitObjCmd(clientData, interp, objc, objv)
Tcl_Interp *interp;
int objc;
Tcl_Obj *CONST objv[];
-#else
+#else /* TCL_MAJOR_VERSION < 8 */
static int ip_rb_threadTkWaitCommand _((ClientData, Tcl_Interp *, int,
char *[]));
static int
@@ -1320,15 +2502,17 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv)
(char *) NULL };
enum options { TKWAIT_VARIABLE, TKWAIT_VISIBILITY, TKWAIT_WINDOW };
char *nameString;
- int dummy;
+ int ret, dummy;
+ int thr_crit_bup;
+ volatile VALUE current_thread = rb_thread_current();
DUMP1("Ruby's 'thread_tkwait' is called");
- if (eventloop_thread == rb_thread_current()) {
+ if (rb_thread_alone() || eventloop_thread == current_thread) {
#if TCL_MAJOR_VERSION >= 8
DUMP1("call ip_rbTkWaitObjCmd");
return ip_rbTkWaitObjCmd(clientData, interp, objc, objv);
-#else
+#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("call rb_VwaitCommand");
return ip_rbTkWaitCommand(clientData, interp, objc, objv);
#endif
@@ -1338,27 +2522,45 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv)
#ifdef Tcl_WrongNumArgs
Tcl_WrongNumArgs(interp, 1, objv, "variable|visibility|window name");
#else
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
#if TCL_MAJOR_VERSION >= 8
- Tcl_AppendResult(interp, "wrong # args: should be \"",
+ Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
Tcl_GetStringFromObj(objv[0], &dummy),
" variable|visibility|window name\"",
(char *) NULL);
-#else
- Tcl_AppendResult(interp, "wrong # args: should be \"",
+#else /* TCL_MAJOR_VERSION < 8 */
+ Tcl_AppendResult(interp, "wrong number of arguments: should be \"",
objv[0], " variable|visibility|window name\"",
(char *) NULL);
#endif
+
+ rb_thread_critical = thr_crit_bup;
#endif
return TCL_ERROR;
}
#if TCL_MAJOR_VERSION >= 8
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+ /*
if (Tcl_GetIndexFromObj(interp, objv[1],
(CONST84 char **)optionStrings,
"option", 0, &index) != TCL_OK) {
return TCL_ERROR;
}
-#else
+ */
+ ret = Tcl_GetIndexFromObj(interp, objv[1],
+ (CONST84 char **)optionStrings,
+ "option", 0, &index);
+
+ rb_thread_critical = thr_crit_bup;
+
+ if (ret != TCL_OK) {
+ return TCL_ERROR;
+ }
+#else /* TCL_MAJOR_VERSION < 8 */
{
int c = objv[1][0];
size_t length = strlen(objv[1]);
@@ -1380,85 +2582,139 @@ ip_rb_threadTkWaitCommand(clientData, interp, objc, objv)
}
#endif
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
#if TCL_MAJOR_VERSION >= 8
/* nameString = Tcl_GetString(objv[2]); */
nameString = Tcl_GetStringFromObj(objv[2], &dummy);
-#else
+#else /* TCL_MAJOR_VERSION < 8 */
nameString = objv[2];
#endif
param = (struct th_vwait_param *)Tcl_Alloc(sizeof(struct th_vwait_param));
- param->thread = rb_thread_current();
+ param->thread = current_thread;
param->done = 0;
+ rb_thread_critical = thr_crit_bup;
+
switch ((enum options) index) {
case TKWAIT_VARIABLE: {
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+ /*
if (Tcl_TraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
rb_threadVwaitProc, (ClientData) param) != TCL_OK) {
return TCL_ERROR;
- };
+ }
+ */
+ ret = Tcl_TraceVar(interp, nameString,
+ TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ rb_threadVwaitProc, (ClientData) param);
- if (!param->done) {
+ rb_thread_critical = thr_crit_bup;
+
+ if (ret != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /* if (!param->done) { */
+ while(!param->done) {
rb_thread_stop();
}
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
Tcl_UntraceVar(interp, nameString,
TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
rb_threadVwaitProc, (ClientData) param);
+
+ rb_thread_critical = thr_crit_bup;
+
break;
}
case TKWAIT_VISIBILITY: {
Tk_Window window;
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
window = Tk_NameToWindow(interp, nameString, tkwin);
if (window == NULL) {
+ rb_thread_critical = thr_crit_bup;
return TCL_ERROR;
}
+
Tk_CreateEventHandler(window,
VisibilityChangeMask|StructureNotifyMask,
rb_threadWaitVisibilityProc, (ClientData) param);
- if (!param->done) {
+
+ rb_thread_critical = thr_crit_bup;
+
+ /* if (!param->done) { */
+ while(!param->done) {
rb_thread_stop();
}
- if (param->done != 1) {
- /*
- * Note that we do not delete the event handler because it
- * was deleted automatically when the window was destroyed.
- */
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ Tk_DeleteEventHandler(window,
+ VisibilityChangeMask|StructureNotifyMask,
+ rb_threadWaitVisibilityProc, (ClientData) param);
+
+ if (param->done != 1) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "window \"", nameString,
"\" was deleted before its visibility changed",
(char *) NULL);
+
+ rb_thread_critical = thr_crit_bup;
+
return TCL_ERROR;
}
- Tk_DeleteEventHandler(window,
- VisibilityChangeMask|StructureNotifyMask,
- rb_threadWaitVisibilityProc, (ClientData) param);
+
+ rb_thread_critical = thr_crit_bup;
+
break;
}
case TKWAIT_WINDOW: {
Tk_Window window;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
window = Tk_NameToWindow(interp, nameString, tkwin);
if (window == NULL) {
+ rb_thread_critical = thr_crit_bup;
return TCL_ERROR;
}
+
Tk_CreateEventHandler(window, StructureNotifyMask,
rb_threadWaitWindowProc, (ClientData) param);
- if (!param->done) {
+
+ rb_thread_critical = thr_crit_bup;
+
+ /* if (!param->done) { */
+ while(!param->done) {
rb_thread_stop();
}
- /*
- * Note: there's no need to delete the event handler. It was
- * deleted automatically when the window was destroyed.
- */
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ Tk_DeleteEventHandler(window, StructureNotifyMask,
+ rb_threadWaitWindowProc, (ClientData) param);
+
+ rb_thread_critical = thr_crit_bup;
+
break;
}
- }
+ } /* end of 'switch' statement */
Tcl_Free((char *)param);
@@ -1499,16 +2755,48 @@ ip_thread_tkwait(self, mode, target)
/* destroy interpreter */
+VALUE del_root(ip)
+ Tcl_Interp *ip;
+{
+ Tcl_Preserve(ip);
+ Tk_DestroyWindow(Tk_MainWindow(ip));
+ Tcl_Release(ip);
+ return Qnil;
+}
+
static void
ip_free(ptr)
struct tcltkip *ptr;
{
- DUMP1("Tcl_DeleteInterp");
+ int try = 3;
+ Tcl_CmdInfo info;
+ int thr_crit_bup;
+
+ DUMP1("free Tcl Interp");
if (ptr) {
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ if (!Tcl_InterpDeleted(ptr->ip)) {
+ Tcl_ResetResult(ptr->ip);
+ Tcl_Preserve(ptr->ip);
+ if (Tcl_GetCommandInfo(ptr->ip, finalize_hook_name, &info)) {
+ DUMP2("call finalize hook proc '%s'", finalize_hook_name);
+ Tcl_Eval(ptr->ip, finalize_hook_name);
+ }
+ for(; try > 0; try--) {
+ if (!Tk_GetNumMainWindows()) break;
+ rb_protect(del_root, (VALUE)(ptr->ip), 0);
+ }
+ Tcl_Release(ptr->ip);
+ Tcl_DeleteInterp(ptr->ip);
+ }
Tcl_Release((ClientData)ptr->ip);
- Tcl_DeleteInterp(ptr->ip);
free(ptr);
+
+ rb_thread_critical = thr_crit_bup;
}
+ DUMP1("complete freeing Tcl Interp");
}
/* create and initialize interpreter */
@@ -1530,6 +2818,7 @@ ip_init(argc, argv, self)
VALUE argv0, opts;
int cnt;
int with_tk = 1;
+ Tk_Window mainWin;
/* create object */
Data_Get_Struct(self, struct tcltkip, ptr);
@@ -1546,7 +2835,11 @@ ip_init(argc, argv, self)
/* from Tcl_AppInit() */
DUMP1("Tcl_Init");
if (Tcl_Init(ptr->ip) == TCL_ERROR) {
+#if TCL_MAJOR_VERSION >= 8
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+#endif
}
/* set variables */
@@ -1554,7 +2847,7 @@ ip_init(argc, argv, self)
switch(cnt) {
case 2:
/* options */
- if (opts == Qnil || opts == Qfalse) {
+ if (NIL_P(opts) || opts == Qfalse) {
/* without Tk */
with_tk = 0;
} else {
@@ -1562,7 +2855,7 @@ ip_init(argc, argv, self)
}
case 1:
/* argv0 */
- if (argv0 != Qnil) {
+ if (!NIL_P(argv0)) {
Tcl_SetVar(ptr->ip, "argv0", StringValuePtr(argv0), 0);
}
case 0:
@@ -1574,70 +2867,119 @@ ip_init(argc, argv, self)
if (with_tk) {
DUMP1("Tk_Init");
if (Tk_Init(ptr->ip) == TCL_ERROR) {
+#if TCL_MAJOR_VERSION >= 8
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+#endif
}
DUMP1("Tcl_StaticPackage(\"Tk\")");
#if TCL_MAJOR_VERSION >= 8
Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init, Tk_SafeInit);
-#else
+#else /* TCL_MAJOR_VERSION < 8 */
Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init,
(Tcl_PackageInitProc *) NULL);
#endif
}
+ /* get main window */
+ mainWin = Tk_MainWindow(ptr->ip);
+
/* 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_CreateObjCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL,
(Tcl_CmdDeleteProc *)NULL);
-#else
+ DUMP1("Tcl_CreateObjCommand(\"ruby_eval\")");
+ Tcl_CreateObjCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL,
+ (Tcl_CmdDeleteProc *)NULL);
+ DUMP1("Tcl_CreateObjCommand(\"ruby_cmd\")");
+ Tcl_CreateObjCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL,
+ (Tcl_CmdDeleteProc *)NULL);
+#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"ruby\")");
- Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby, (ClientData)NULL,
+ Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby_eval, (ClientData)NULL,
+ (Tcl_CmdDeleteProc *)NULL);
+ DUMP1("Tcl_CreateCommand(\"ruby_eval\")");
+ Tcl_CreateCommand(ptr->ip, "ruby_eval", ip_ruby_eval, (ClientData)NULL,
(Tcl_CmdDeleteProc *)NULL);
+ DUMP1("Tcl_CreateCommand(\"ruby_cmd\")");
+ Tcl_CreateCommand(ptr->ip, "ruby_cmd", ip_ruby_cmd, (ClientData)NULL,
+ (Tcl_CmdDeleteProc *)NULL);
+#endif
+
+#if 0 /*
+ Disable the following "update" and "thread_update". Bcause,
+ they don't work in a callback-proc. After calling update in
+ a callback-proc, the callback proc never be worked.
+ If the problem will be fixed in the future, may enable the
+ functions.
+ */
+ /* replace 'update' command */
+# if TCL_MAJOR_VERSION >= 8
+ DUMP1("Tcl_CreateObjCommand(\"update\")");
+ Tcl_CreateObjCommand(ptr->ip, "update", ip_rbUpdateObjCmd,
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+# else /* TCL_MAJOR_VERSION < 8 */
+ DUMP1("Tcl_CreateCommand(\"update\")");
+ Tcl_CreateCommand(ptr->ip, "update", ip_rbUpdateCommand,
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+# endif
+
+ /* add 'thread_update' command */
+# if TCL_MAJOR_VERSION >= 8
+ DUMP1("Tcl_CreateObjCommand(\"thread_update\")");
+ Tcl_CreateObjCommand(ptr->ip, "thread_update", ip_rb_threadUpdateObjCmd,
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+# else /* TCL_MAJOR_VERSION < 8 */
+ DUMP1("Tcl_CreateCommand(\"thread_update\")");
+ Tcl_CreateCommand(ptr->ip, "thread_update", ip_rb_threadUpdateCommand,
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+# endif
#endif
/* replace 'vwait' command */
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"vwait\")");
Tcl_CreateObjCommand(ptr->ip, "vwait", ip_rbVwaitObjCmd,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
-#else
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"vwait\")");
Tcl_CreateCommand(ptr->ip, "vwait", ip_rbVwaitCommand,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#endif
/* replace 'tkwait' command */
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"tkwait\")");
Tcl_CreateObjCommand(ptr->ip, "tkwait", ip_rbTkWaitObjCmd,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
-#else
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"tkwait\")");
Tcl_CreateCommand(ptr->ip, "tkwait", ip_rbTkWaitCommand,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#endif
/* add 'thread_vwait' command */
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"thread_vwait\")");
Tcl_CreateObjCommand(ptr->ip, "thread_vwait", ip_rb_threadVwaitObjCmd,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
-#else
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"thread_vwait\")");
Tcl_CreateCommand(ptr->ip, "thread_vwait", ip_rb_threadVwaitCommand,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#endif
/* add 'thread_tkwait' command */
#if TCL_MAJOR_VERSION >= 8
DUMP1("Tcl_CreateObjCommand(\"thread_tkwait\")");
Tcl_CreateObjCommand(ptr->ip, "thread_tkwait", ip_rb_threadTkWaitObjCmd,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
-#else
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
+#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tcl_CreateCommand(\"thread_tkwait\")");
Tcl_CreateCommand(ptr->ip, "thread_tkwait", ip_rb_threadTkWaitCommand,
- (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL);
+ (ClientData)mainWin, (Tcl_CmdDeleteProc *)NULL);
#endif
return self;
@@ -1651,9 +2993,10 @@ ip_create_slave(argc, argv, self)
{
struct tcltkip *master = get_ip(self);
struct tcltkip *slave = ALLOC(struct tcltkip);
- VALUE name;
VALUE safemode;
+ VALUE name;
int safe;
+ int thr_crit_bup;
/* safe-mode check */
if (rb_scan_args(argc, argv, "11", &name, &safemode) == 1) {
@@ -1661,21 +3004,26 @@ ip_create_slave(argc, argv, self)
}
if (Tcl_IsSafe(master->ip) == 1) {
safe = 1;
- } else if (safemode == Qfalse || safemode == Qnil) {
+ } else if (safemode == Qfalse || NIL_P(safemode)) {
safe = 0;
rb_secure(4);
} else {
safe = 1;
}
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
/* create slave-ip */
- if ((slave->ip = Tcl_CreateSlave(master->ip, StringValuePtr(name), safe))
- == NULL) {
+ slave->ip = Tcl_CreateSlave(master->ip, StringValuePtr(name), safe);
+ if (slave->ip == NULL) {
rb_raise(rb_eRuntimeError, "fail to create the new slave interpreter");
}
Tcl_Preserve((ClientData)slave->ip);
slave->return_value = 0;
+ rb_thread_critical = thr_crit_bup;
+
return Data_Wrap_Struct(CLASS_OF(self), 0, ip_free, slave);
}
@@ -1687,7 +3035,11 @@ ip_make_safe(self)
struct tcltkip *ptr = get_ip(self);
if (Tcl_MakeSafe(ptr->ip) == TCL_ERROR) {
+#if TCL_MAJOR_VERSION >= 8
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+#endif
}
return self;
@@ -1734,30 +3086,124 @@ ip_is_deleted_p(self)
}
+static VALUE
+#ifdef HAVE_STDARG_PROTOTYPES
+create_ip_exc(VALUE interp, VALUE exc, const char *fmt, ...)
+#else
+create_ip_exc(interp, exc, fmt, va_alist)
+ VALUE interp:
+ VALUE exc;
+ const char *fmt;
+ va_dcl
+#endif
+{
+ va_list args;
+ char buf[BUFSIZ];
+ VALUE einfo;
+
+ va_init_list(args,fmt);
+ vsnprintf(buf, BUFSIZ, fmt, args);
+ buf[BUFSIZ - 1] = '\0';
+ va_end(args);
+ einfo = rb_exc_new2(exc, buf);
+ rb_ivar_set(einfo, ID_at_interp, interp);
+ Tcl_ResetResult(get_ip(interp)->ip);
+
+ return einfo;
+}
+
+static VALUE
+ip_get_result_string_obj(interp)
+ Tcl_Interp *interp;
+{
+#if TCL_MAJOR_VERSION >= 8
+ int len;
+ char *s;
+
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ s = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &len);
+ return(rb_tainted_str_new(s, len));
+
+# else /* TCL_VERSION >= 8.1 */
+ volatile VALUE strval;
+ Tcl_Obj *retobj = Tcl_GetObjResult(interp);
+ int thr_crit_bup;
+
+ Tcl_IncrRefCount(retobj);
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ if (Tcl_GetCharLength(retobj) != Tcl_UniCharLen(Tcl_GetUnicode(retobj))) {
+ /* possibly binary string */
+ s = Tcl_GetByteArrayFromObj(retobj, &len);
+ strval = rb_tainted_str_new(s, len);
+ rb_ivar_set(strval, ID_at_enc, rb_str_new2("binary"));
+ } else {
+ /* possibly text string */
+ s = Tcl_GetStringFromObj(retobj, &len);
+ strval = rb_tainted_str_new(s, len);
+ }
+
+ rb_thread_critical = thr_crit_bup;
+
+ Tcl_DecrRefCount(retobj);
+
+ return(strval);
+
+# endif
+#else /* TCL_MAJOR_VERSION < 8 */
+ return(rb_tainted_str_new2(interp->result));
+#endif
+}
+
/* eval string in tcl by Tcl_Eval() */
static VALUE
-ip_eval_real(self, str)
+ip_eval_real(self, cmd_str, cmd_len)
VALUE self;
- VALUE str;
+ char *cmd_str;
+ int cmd_len;
{
char *s;
- char *buf; /* Tcl_Eval requires re-writable string region */
+ int len;
struct tcltkip *ptr = get_ip(self);
+ int thr_crit_bup;
+
+#if TCL_MAJOR_VERSION >= 8
+ /* call Tcl_EvalObj() */
+ {
+ Tcl_Obj *cmd;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ cmd = Tcl_NewStringObj(cmd_str, cmd_len);
+ Tcl_IncrRefCount(cmd);
+ ptr->return_value = Tcl_EvalObj(ptr->ip, cmd);
+ /* ptr->return_value = Tcl_GlobalEvalObj(ptr->ip, cmd); */
+ Tcl_DecrRefCount(cmd);
+
+ rb_thread_critical = thr_crit_bup;
+ }
+#else /* TCL_MAJOR_VERSION < 8 */
+ DUMP2("Tcl_Eval(%s)", cmd_str);
+ ptr->return_value = Tcl_Eval(ptr->ip, cmd_str);
+ /* ptr->return_value = Tcl_GlobalEval(ptr->ip, cmd_str); */
+#endif
- /* call Tcl_Eval() */
- s = StringValuePtr(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) {
- rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+#if TCL_MAJOR_VERSION >= 8
+ return create_ip_exc(self, rb_eRuntimeError,
+ "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ return create_ip_exc(self, rb_eRuntimeError,
+ "%s", ptr->ip->result);
+#endif
}
DUMP2("(TCL_Eval result) %d", ptr->return_value);
/* pass back the result (as string) */
- /* return(rb_str_new2(ptr->ip->result)); */
- return(rb_tainted_str_new2(ptr->ip->result));
+ return ip_get_result_string_obj(ptr->ip);
}
static VALUE
@@ -1770,7 +3216,7 @@ evq_safelevel_handler(arg, evq)
Data_Get_Struct(evq, struct eval_queue, q);
DUMP2("(safe-level handler) $SAFE = %d", q->safe_level);
rb_set_safe_level(q->safe_level);
- return ip_eval_real(q->obj, q->str);
+ return ip_eval_real(q->interp, q->str, q->len);
}
int eval_queue_handler _((Tcl_Event *, int));
@@ -1780,12 +3226,13 @@ eval_queue_handler(evPtr, flags)
int flags;
{
struct eval_queue *q = (struct eval_queue *)evPtr;
+ volatile VALUE ret;
DUMP2("do_eval_queue_handler : evPtr = %p", evPtr);
DUMP2("eval queue_thread : %lx", rb_thread_current());
DUMP2("added by thread : %lx", q->thread);
- if (q->done) {
+ if (*(q->done)) {
DUMP1("processed by another event-loop");
return 0;
} else {
@@ -1793,20 +3240,31 @@ eval_queue_handler(evPtr, flags)
}
/* process it */
- q->done = 1;
+ *(q->done) = 1;
/* check safe-level */
if (rb_safe_level() != q->safe_level) {
- *(q->result)
- = rb_funcall(rb_proc_new(evq_safelevel_handler,
- Data_Wrap_Struct(rb_cData,0,0,q)),
- rb_intern("call"), 0);
+ volatile VALUE q_dat;
+#ifdef HAVE_NATIVETHREAD
+ if (!is_ruby_native_thread()) {
+ rb_bug("cross-thread violation on eval_queue_handler()");
+ }
+#endif
+ q_dat = Data_Wrap_Struct(rb_cData,eval_queue_mark,0,q);
+ ret = rb_funcall(rb_proc_new(evq_safelevel_handler, q_dat),
+ ID_call, 0);
} else {
- DUMP2("call eval_real (for caller thread:%lx)", q->thread);
- DUMP2("call eval_real (current thread:%lx)", rb_thread_current());
- *(q->result) = ip_eval_real(q->obj, q->str);
+ DUMP2("call eval_real (for caller thread:%lx)", q->thread);
+ DUMP2("call eval_real (current thread:%lx)", rb_thread_current());
+ ret = ip_eval_real(q->interp, q->str, q->len);
}
+ /* set result */
+ RARRAY(q->result)->ptr[0] = ret;
+
+ /* complete */
+ *(q->done) = -1;
+
/* back to caller */
DUMP2("back to caller (caller thread:%lx)", q->thread);
DUMP2(" (current thread:%lx)", rb_thread_current());
@@ -1822,19 +3280,27 @@ ip_eval(self, str)
VALUE self;
VALUE str;
{
- struct eval_queue *tmp;
+ struct eval_queue *evq;
+ char *eval_str;
+ int *alloc_done;
+ int thr_crit_bup;
VALUE current = rb_thread_current();
- VALUE result;
- VALUE *alloc_result;
+ volatile VALUE result = rb_ary_new2(1);
+ volatile VALUE ret;
Tcl_QueuePosition position;
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+ StringValue(str);
+ rb_thread_critical = thr_crit_bup;
+
if (eventloop_thread == 0 || current == eventloop_thread) {
if (eventloop_thread) {
DUMP2("eval from current eventloop %lx", current);
} else {
DUMP2("eval from thread:%lx but no eventloop", current);
}
- result = ip_eval_real(self, str);
+ result = ip_eval_real(self, RSTRING(str)->ptr, RSTRING(str)->len);
if (rb_obj_is_kind_of(result, rb_eException)) {
rb_exc_raise(result);
}
@@ -1843,39 +3309,53 @@ ip_eval(self, str)
DUMP2("eval from thread %lx (NOT current eventloop)", current);
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
/* allocate memory (protected from Tcl_ServiceEvent) */
- alloc_result = ALLOC(VALUE);
+ alloc_done = (int*)ALLOC(int);
+ *alloc_done = 0;
+
+ eval_str = ALLOC_N(char, RSTRING(str)->len + 1);
+ strncpy(eval_str, RSTRING(str)->ptr, RSTRING(str)->len);
+ eval_str[RSTRING(str)->len] = 0;
/* allocate memory (freed by Tcl_ServiceEvent) */
- tmp = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue));
+ evq = (struct eval_queue *)Tcl_Alloc(sizeof(struct eval_queue));
/* construct event data */
- tmp->done = 0;
- tmp->obj = self;
- tmp->str = str;
- tmp->result = alloc_result;
- tmp->thread = current;
- tmp->safe_level = rb_safe_level();
- tmp->ev.proc = eval_queue_handler;
+ evq->done = alloc_done;
+ evq->str = eval_str;
+ evq->len = RSTRING(str)->len;
+ evq->interp = self;
+ 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");
- Tcl_QueueEvent(&(tmp->ev), position);
+ Tcl_QueueEvent(&(evq->ev), position);
+
+ rb_thread_critical = thr_crit_bup;
/* wait for the handler to be processed */
DUMP2("wait for handler (current thread:%lx)", current);
- rb_thread_stop();
+ while(*alloc_done >= 0) {
+ rb_thread_stop();
+ }
DUMP2("back from handler (current thread:%lx)", current);
/* get result & free allocated memory */
- result = *alloc_result;
- free(alloc_result);
- if (rb_obj_is_kind_of(result, rb_eException)) {
- rb_exc_raise(result);
+ ret = RARRAY(result)->ptr[0];
+ free(alloc_done);
+ free(eval_str);
+ if (rb_obj_is_kind_of(ret, rb_eException)) {
+ rb_exc_raise(ret);
}
- return result;
+ return ret;
}
@@ -1885,12 +3365,27 @@ lib_restart(self)
VALUE self;
{
struct tcltkip *ptr = get_ip(self);
+ int thr_crit_bup;
rb_secure(4);
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
/* destroy the root wdiget */
- /* ptr->return_value = Tcl_Eval(ptr->ip, "destroy ."); */
- ptr->return_value = FIX2INT(ip_eval(self, "destroy ."));
+ ptr->return_value = Tcl_Eval(ptr->ip, "destroy .");
+ /* ignore ERROR */
+ DUMP2("(TCL_Eval result) %d", ptr->return_value);
+ Tcl_ResetResult(ptr->ip);
+
+ /* delete namespace ( tested on tk8.4.5 ) */
+ ptr->return_value = Tcl_Eval(ptr->ip, "namespace delete ::tk::msgcat");
+ /* ignore ERROR */
+ DUMP2("(TCL_Eval result) %d", ptr->return_value);
+ Tcl_ResetResult(ptr->ip);
+
+ /* delete trace proc ( tested on tk8.4.5 ) */
+ ptr->return_value = Tcl_Eval(ptr->ip, "trace vdelete ::tk_strictMotif w ::tk::EventMotifBindings");
/* ignore ERROR */
DUMP2("(TCL_Eval result) %d", ptr->return_value);
Tcl_ResetResult(ptr->ip);
@@ -1900,21 +3395,27 @@ lib_restart(self)
if (Tcl_IsSafe(ptr->ip)) {
DUMP1("Tk_SafeInit");
if (Tk_SafeInit(ptr->ip) == TCL_ERROR) {
- rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+ rb_thread_critical = thr_crit_bup;
+ /* rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); */
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
}
} else {
DUMP1("Tk_Init");
if (Tk_Init(ptr->ip) == TCL_ERROR) {
- rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+ rb_thread_critical = thr_crit_bup;
+ /* rb_raise(rb_eRuntimeError, "%s", ptr->ip->result); */
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
}
}
-#else
+#else /* TCL_MAJOR_VERSION < 8 */
DUMP1("Tk_Init");
if (Tk_Init(ptr->ip) == TCL_ERROR) {
rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
}
#endif
+ rb_thread_critical = thr_crit_bup;
+
return Qnil;
}
@@ -1934,141 +3435,389 @@ ip_restart(self)
}
static VALUE
-ip_toUTF8(self, str, encodename)
- VALUE self;
- VALUE str;
+lib_toUTF8_core(ip_obj, src, encodename)
+ VALUE ip_obj;
+ VALUE src;
VALUE encodename;
{
+ volatile VALUE str = src;
+
#ifdef TCL_UTF_MAX
Tcl_Interp *interp;
Tcl_Encoding encoding;
Tcl_DString dstr;
+ int taint_flag = OBJ_TAINTED(str);
struct tcltkip *ptr;
char *buf;
+ int thr_crit_bup;
- ptr = get_ip(self);
- interp = ptr->ip;
+ if (NIL_P(ip_obj)) {
+ interp = (Tcl_Interp *)NULL;
+ } else {
+ interp = get_ip(ip_obj)->ip;
+ }
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ if (NIL_P(encodename)) {
+ if (TYPE(str) == T_STRING) {
+ volatile VALUE enc;
+
+ enc = rb_ivar_get(str, ID_at_enc);
+ if (NIL_P(enc)) {
+ if (NIL_P(ip_obj)) {
+ encoding = (Tcl_Encoding)NULL;
+ } else {
+ enc = rb_ivar_get(ip_obj, ID_at_enc);
+ if (NIL_P(enc)) {
+ encoding = (Tcl_Encoding)NULL;
+ } else {
+ StringValue(enc);
+ encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr);
+ if (encoding == (Tcl_Encoding)NULL) {
+ rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING(enc)->ptr);
+ }
+ }
+ }
+ } else {
+ StringValue(enc);
+ if (strcmp(RSTRING(enc)->ptr, "binary") == 0) {
+ rb_thread_critical = thr_crit_bup;
+ return str;
+ }
+ encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr);
+ if (encoding == (Tcl_Encoding)NULL) {
+ rb_warning("string has unknown encoding information (@encoding:'%s')", RSTRING(enc)->ptr);
+ }
+ }
+ } else {
+ encoding = (Tcl_Encoding)NULL;
+ }
+ } else {
+ StringValue(encodename);
+ encoding = Tcl_GetEncoding(interp, RSTRING(encodename)->ptr);
+ if (encoding == (Tcl_Encoding)NULL) {
+ rb_warning("unknown encoding name '%s'", RSTRING(encodename)->ptr);
+ }
+ }
- StringValue(encodename);
StringValue(str);
- encoding = Tcl_GetEncoding(interp, RSTRING(encodename)->ptr);
- if (!RSTRING(str)->len) return str;
- buf = ALLOCA_N(char,strlen(RSTRING(str)->ptr)+1);
- strcpy(buf, RSTRING(str)->ptr);
+ if (!RSTRING(str)->len) {
+ rb_thread_critical = thr_crit_bup;
+ return str;
+ }
+
+ buf = ALLOC_N(char,(RSTRING(str)->len)+1);
+ strncpy(buf, RSTRING(str)->ptr, RSTRING(str)->len);
+ buf[RSTRING(str)->len] = 0;
Tcl_DStringInit(&dstr);
Tcl_DStringFree(&dstr);
- Tcl_ExternalToUtfDString(encoding,buf,strlen(buf),&dstr);
- /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */
- str = rb_tainted_str_new2(Tcl_DStringValue(&dstr));
+ /* Tcl_ExternalToUtfDString(encoding,buf,strlen(buf),&dstr); */
+ Tcl_ExternalToUtfDString(encoding, buf, RSTRING(str)->len, &dstr);
+
+ /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */
+ str = rb_str_new2(Tcl_DStringValue(&dstr));
+ rb_ivar_set(str, ID_at_enc, rb_tainted_str_new2("utf-8"));
+ if (taint_flag) OBJ_TAINT(str);
- Tcl_FreeEncoding(encoding);
+ if (encoding != (Tcl_Encoding)NULL) {
+ Tcl_FreeEncoding(encoding);
+ }
Tcl_DStringFree(&dstr);
+
+ free(buf);
+
+ rb_thread_critical = thr_crit_bup;
#endif
+
return str;
}
static VALUE
-ip_fromUTF8(self, str, encodename)
+lib_toUTF8(argc, argv, self)
+ int argc;
+ VALUE *argv;
VALUE self;
- VALUE str;
+{
+ VALUE str, encodename;
+
+ if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
+ encodename = Qnil;
+ }
+ return lib_toUTF8_core(Qnil, str, encodename);
+}
+
+static VALUE
+ip_toUTF8(argc, argv, self)
+ int argc;
+ VALUE *argv;
+ VALUE self;
+{
+ VALUE str, encodename;
+
+ if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
+ encodename = Qnil;
+ }
+ return lib_toUTF8_core(self, str, encodename);
+}
+
+static VALUE
+lib_fromUTF8_core(ip_obj, src, encodename)
+ VALUE ip_obj;
+ VALUE src;
VALUE encodename;
{
+ volatile VALUE str = src;
+
#ifdef TCL_UTF_MAX
Tcl_Interp *interp;
Tcl_Encoding encoding;
Tcl_DString dstr;
- struct tcltkip *ptr;
+ int taint_flag = OBJ_TAINTED(str);
char *buf;
+ int thr_crit_bup;
- ptr = get_ip(self);
- interp = ptr->ip;
+ if (NIL_P(ip_obj)) {
+ interp = (Tcl_Interp *)NULL;
+ } else {
+ interp = get_ip(ip_obj)->ip;
+ }
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ if (NIL_P(encodename)) {
+ volatile VALUE enc;
+
+ if (TYPE(str) == T_STRING) {
+ enc = rb_ivar_get(str, ID_at_enc);
+ if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) {
+ rb_thread_critical = thr_crit_bup;
+ return str;
+ }
+ }
+
+ if (NIL_P(ip_obj)) {
+ encoding = (Tcl_Encoding)NULL;
+ } else {
+ enc = rb_ivar_get(ip_obj, ID_at_enc);
+ if (NIL_P(enc)) {
+ encoding = (Tcl_Encoding)NULL;
+ } else {
+ StringValue(enc);
+ encoding = Tcl_GetEncoding(interp, RSTRING(enc)->ptr);
+ if (encoding == (Tcl_Encoding)NULL) {
+ rb_warning("Tk-interp has unknown encoding information (@encoding:'%s')", RSTRING(enc)->ptr);
+ } else {
+ encodename = rb_obj_dup(enc);
+ }
+ }
+ }
+
+ } else {
+ StringValue(encodename);
+
+ if (strcmp(RSTRING(encodename)->ptr, "binary") == 0) {
+ char *s;
+ int len;
+
+ s = Tcl_GetByteArrayFromObj(Tcl_NewStringObj(RSTRING(str)->ptr,
+ RSTRING(str)->len),
+ &len);
+ str = rb_tainted_str_new(s, len);
+ rb_ivar_set(str, ID_at_enc, rb_tainted_str_new2("binary"));
+
+ rb_thread_critical = thr_crit_bup;
+ return str;
+ }
+
+ encoding = Tcl_GetEncoding(interp, RSTRING(encodename)->ptr);
+ if (encoding == (Tcl_Encoding)NULL) {
+ rb_warning("unknown encoding name '%s'", RSTRING(encodename)->ptr);
+ encodename = Qnil;
+ }
+ }
- StringValue(encodename);
StringValue(str);
- encoding = Tcl_GetEncoding(interp,RSTRING(encodename)->ptr);
- if (!RSTRING(str)->len) return str;
- buf = ALLOCA_N(char,strlen(RSTRING(str)->ptr)+1);
- strcpy(buf,RSTRING(str)->ptr);
+
+ if (RSTRING(str)->len == 0) {
+ rb_thread_critical = thr_crit_bup;
+ return rb_tainted_str_new2("");
+ }
+
+ buf = ALLOC_N(char,strlen(RSTRING(str)->ptr)+1);
+ strncpy(buf, RSTRING(str)->ptr, RSTRING(str)->len);
+ buf[RSTRING(str)->len] = 0;
Tcl_DStringInit(&dstr);
Tcl_DStringFree(&dstr);
- Tcl_UtfToExternalDString(encoding,buf,strlen(buf),&dstr);
- /* str = rb_str_new2(Tcl_DStringValue(&dstr)); */
- str = rb_tainted_str_new2(Tcl_DStringValue(&dstr));
+ /* Tcl_UtfToExternalDString(encoding,buf,strlen(buf),&dstr); */
+ Tcl_UtfToExternalDString(encoding,buf,RSTRING(str)->len,&dstr);
+
+ /* str = rb_tainted_str_new2(Tcl_DStringValue(&dstr)); */
+ str = rb_str_new2(Tcl_DStringValue(&dstr));
+ rb_ivar_set(str, ID_at_enc, encodename);
+ if (taint_flag) OBJ_TAINT(str);
- Tcl_FreeEncoding(encoding);
+ if (encoding != (Tcl_Encoding)NULL) {
+ Tcl_FreeEncoding(encoding);
+ }
Tcl_DStringFree(&dstr);
+ free(buf);
+
+ rb_thread_critical = thr_crit_bup;
#endif
+
return str;
}
+static VALUE
+lib_fromUTF8(argc, argv, self)
+ int argc;
+ VALUE *argv;
+ VALUE self;
+{
+ VALUE str, encodename;
+
+ if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
+ encodename = Qnil;
+ }
+ return lib_fromUTF8_core(Qnil, str, encodename);
+}
static VALUE
-#ifdef HAVE_STDARG_PROTOTYPES
-create_ip_exc(VALUE interp, VALUE exc, const char *fmt, ...)
-#else
-create_ip_exc(interp, exc, fmt, va_alist)
- VALUE interp:
- VALUE exc;
- const char *fmt;
- va_dcl
-#endif
+ip_fromUTF8(argc, argv, self)
+ int argc;
+ VALUE *argv;
+ VALUE self;
{
- va_list args;
- char buf[BUFSIZ];
- VALUE einfo;
+ VALUE str, encodename;
- va_init_list(args,fmt);
- vsnprintf(buf, BUFSIZ, fmt, args);
- buf[BUFSIZ - 1] = '\0';
- va_end(args);
- einfo = rb_exc_new2(exc, buf);
- rb_iv_set(einfo, "interp", interp);
- Tcl_ResetResult(get_ip(interp)->ip);
- return einfo;
+ if (rb_scan_args(argc, argv, "11", &str, &encodename) == 1) {
+ encodename = Qnil;
+ }
+ return lib_fromUTF8_core(self, str, encodename);
+}
+
+static VALUE
+lib_UTF_backslash_core(self, str, all_bs)
+ VALUE self;
+ VALUE str;
+ int all_bs;
+{
+#ifdef TCL_UTF_MAX
+ char *src_buf, *dst_buf, *ptr;
+ int read_len = 0, dst_len = 0;
+ int taint_flag = OBJ_TAINTED(str);
+ int thr_crit_bup;
+
+ StringValue(str);
+ if (!RSTRING(str)->len) {
+ return str;
+ }
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ src_buf = ALLOC_N(char,(RSTRING(str)->len)+1);
+ strncpy(src_buf, RSTRING(str)->ptr, RSTRING(str)->len);
+ src_buf[RSTRING(str)->len] = 0;
+
+ dst_buf = ALLOC_N(char,(RSTRING(str)->len)+1);
+
+ ptr = src_buf;
+ while(RSTRING(str)->len > ptr - src_buf) {
+ if (*ptr == '\\' && (all_bs || *(ptr + 1) == 'u')) {
+ dst_len += Tcl_UtfBackslash(ptr, &read_len, (dst_buf + dst_len));
+ ptr += read_len;
+ } else {
+ *(dst_buf + (dst_len++)) = *(ptr++);
+ }
+ }
+
+ str = rb_str_new(dst_buf, dst_len);
+ if (taint_flag) OBJ_TAINT(str);
+
+ free(src_buf);
+ free(dst_buf);
+
+ rb_thread_critical = thr_crit_bup;
+#endif
+
+ return str;
+}
+
+static VALUE
+lib_UTF_backslash(self, str)
+ VALUE self;
+ VALUE str;
+{
+ return lib_UTF_backslash_core(self, str, 0);
}
+static VALUE
+lib_Tcl_backslash(self, str)
+ VALUE self;
+ VALUE str;
+{
+ return lib_UTF_backslash_core(self, str, 1);
+}
+#if TCL_MAJOR_VERSION >= 8
+static VALUE
+ip_invoke_core(interp, objc, objv)
+ VALUE interp;
+ int objc;
+ Tcl_Obj **objv;
+#else
static VALUE
-ip_invoke_real(argc, argv, obj)
+ip_invoke_core(interp, argc, argv)
+ VALUE interp;
int argc;
- VALUE *argv;
- VALUE obj;
+ char **argv;
+#endif
{
- VALUE v;
- struct tcltkip *ptr; /* tcltkip data struct */
+ struct tcltkip *ptr;
int i;
Tcl_CmdInfo info;
- char *cmd, *s;
- char **av = (char **)NULL;
+ char *cmd;
+ char *s;
+ int len;
+ int thr_crit_bup;
+
#if TCL_MAJOR_VERSION >= 8
- Tcl_Obj **ov = (Tcl_Obj **)NULL;
+ int argc = objc;
+ char **argv = (char **)NULL;
Tcl_Obj *resultPtr;
#endif
- DUMP2("invoke_real called by thread:%lx", rb_thread_current());
- /* get the command name string */
- v = argv[0];
- cmd = StringValuePtr(v);
-
/* get the data struct */
- ptr = get_ip(obj);
+ ptr = get_ip(interp);
/* ip is deleted? */
if (Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
return rb_tainted_str_new2("");
}
+ /* 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
+
/* 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("error Tcl_GetCommandInfo");
/* if (event_loop_abort_on_exc || cmd[0] != '.') { */
if (event_loop_abort_on_exc > 0) {
/*rb_ip_raise(obj,rb_eNameError,"invalid command name `%s'",cmd);*/
- return create_ip_exc(obj, rb_eNameError,
+ return create_ip_exc(interp, rb_eNameError,
"invalid command name `%s'", cmd);
} else {
if (event_loop_abort_on_exc < 0) {
@@ -2082,74 +3831,75 @@ ip_invoke_real(argc, argv, obj)
}
DUMP1("end Tcl_GetCommandInfo");
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
/* memory allocation for arguments of this command */
#if TCL_MAJOR_VERSION >= 8
- if (info.isNativeObjectProc) {
- /* object interface */
- ov = (Tcl_Obj **)ALLOCA_N(Tcl_Obj *, argc+1);
- for (i = 0; i < argc; ++i) {
- v = argv[i];
- s = StringValuePtr(v);
- ov[i] = Tcl_NewStringObj(s, RSTRING(v)->len);
- Tcl_IncrRefCount(ov[i]);
- }
- ov[argc] = (Tcl_Obj *)NULL;
- }
- else
-#endif
- {
+ if (!info.isNativeObjectProc) {
/* string interface */
- av = (char **)ALLOCA_N(char *, argc+1);
+ argv = (char **)ALLOC_N(char *, argc+1);
for (i = 0; i < argc; ++i) {
- v = argv[i];
- s = StringValuePtr(v);
- av[i] = ALLOCA_N(char, strlen(s)+1);
- strcpy(av[i], s);
+ argv[i] = Tcl_GetStringFromObj(objv[i], &len);
}
- av[argc] = (char *)NULL;
+ argv[argc] = (char *)NULL;
}
+#endif
Tcl_ResetResult(ptr->ip);
/* Invoke the C procedure */
#if TCL_MAJOR_VERSION >= 8
if (info.isNativeObjectProc) {
- int dummy;
- ptr->return_value = (*info.objProc)(info.objClientData,
- ptr->ip, argc, ov);
-
+ 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, &dummy),
+ Tcl_SetResult(ptr->ip, Tcl_GetStringFromObj(resultPtr, &len),
TCL_VOLATILE);
-
- for (i=0; i<argc; i++) {
- Tcl_DecrRefCount(ov[i]);
- }
+#endif
}
else
#endif
{
- TRAP_BEG;
#if TCL_MAJOR_VERSION >= 8
ptr->return_value = (*info.proc)(info.clientData, ptr->ip,
- argc, (CONST84 char **)av);
+ argc, (CONST84 char **)argv);
+
+ free(argv);
+
#else /* TCL_MAJOR_VERSION < 8 */
- ptr->return_value = (*info.proc)(info.clientData, ptr->ip, argc, av);
+ ptr->return_value = (*info.proc)(info.clientData, ptr->ip,
+ argc, argv);
#endif
- TRAP_END;
}
+ rb_thread_critical = thr_crit_bup;
+
/* exception on mainloop */
if (ptr->return_value == TCL_ERROR) {
if (event_loop_abort_on_exc > 0 && !Tcl_InterpDeleted(ptr->ip)) {
- /*rb_ip_raise(obj, rb_eRuntimeError, "%s", ptr->ip->result);*/
- return create_ip_exc(obj, rb_eRuntimeError, "%s", ptr->ip->result);
+#if TCL_MAJOR_VERSION >= 8
+ return create_ip_exc(interp, rb_eRuntimeError,
+ "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ return create_ip_exc(interp, rb_eRuntimeError,
+ "%s", ptr->ip->result);
+#endif
} else {
if (event_loop_abort_on_exc < 0) {
+#if TCL_MAJOR_VERSION >= 8
+ rb_warning("%s (ignore)", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
rb_warning("%s (ignore)", ptr->ip->result);
+#endif
} else {
+#if TCL_MAJOR_VERSION >= 8
+ rb_warn("%s (ignore)", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
rb_warn("%s (ignore)", ptr->ip->result);
+#endif
}
Tcl_ResetResult(ptr->ip);
return rb_tainted_str_new2("");
@@ -2157,8 +3907,143 @@ ip_invoke_real(argc, argv, obj)
}
/* pass back the result (as string) */
- /* return rb_str_new2(ptr->ip->result); */
- return rb_tainted_str_new2(ptr->ip->result);
+ return ip_get_result_string_obj(ptr->ip);
+}
+
+
+#if TCL_MAJOR_VERSION >= 8
+static Tcl_Obj **
+#else /* TCL_MAJOR_VERSION < 8 */
+static char **
+#endif
+alloc_invoke_arguments(argc, argv)
+ int argc;
+ VALUE *argv;
+{
+ int i;
+ VALUE v;
+ char *s;
+ int thr_crit_bup;
+
+#if TCL_MAJOR_VERSION >= 8
+ Tcl_Obj **av = (Tcl_Obj **)NULL;
+ Tcl_Obj *resultPtr;
+#else /* TCL_MAJOR_VERSION < 8 */
+ char **av = (char **)NULL;
+#endif
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ /* memory allocation */
+#if TCL_MAJOR_VERSION >= 8
+ av = (Tcl_Obj **)ALLOC_N(Tcl_Obj *, argc+1);
+ for (i = 0; i < argc; ++i) {
+ VALUE enc;
+
+ v = argv[i];
+ s = StringValuePtr(v);
+
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ av[i] = Tcl_NewStringObj(s, RSTRING(v)->len);
+# else /* TCL_VERSION >= 8.1 */
+ enc = rb_ivar_get(v, ID_at_enc);
+ if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) {
+ /* binary string */
+ av[i] = Tcl_NewByteArrayObj(s, RSTRING(v)->len);
+ } else if (strlen(s) != RSTRING(v)->len) {
+ /* probably binary string */
+ av[i] = Tcl_NewByteArrayObj(s, RSTRING(v)->len);
+ } else {
+ /* probably text string */
+ av[i] = Tcl_NewStringObj(s, RSTRING(v)->len);
+ }
+# endif
+ Tcl_IncrRefCount(av[i]);
+ }
+ av[argc] = (Tcl_Obj *)NULL;
+
+#else /* TCL_MAJOR_VERSION < 8 */
+ /* string interface */
+ av = (char **)ALLOC_N(char *, argc+1);
+ for (i = 0; i < argc; ++i) {
+ v = argv[i];
+ s = StringValuePtr(v);
+ av[i] = ALLOC_N(char, strlen(s)+1);
+ strcpy(av[i], s);
+ }
+ av[argc] = (char *)NULL;
+#endif
+
+ rb_thread_critical = thr_crit_bup;
+
+ return av;
+}
+
+static void
+free_invoke_arguments(argc, av)
+ int argc;
+#if TCL_MAJOR_VERSION >= 8
+ Tcl_Obj **av;
+#else /* TCL_MAJOR_VERSION < 8 */
+ char **av;
+#endif
+{
+ int i;
+
+ for (i = 0; i < argc; ++i) {
+#if TCL_MAJOR_VERSION >= 8
+ Tcl_DecrRefCount(av[i]);
+#else /* TCL_MAJOR_VERSION < 8 */
+ free(av[i]);
+#endif
+ }
+ free(av);
+}
+
+static VALUE
+ip_invoke_real(argc, argv, interp)
+ int argc;
+ VALUE *argv;
+ VALUE interp;
+{
+ VALUE v;
+ struct tcltkip *ptr; /* tcltkip data struct */
+ int i;
+ Tcl_CmdInfo info;
+ char *s;
+ int len;
+ int thr_crit_bup;
+
+#if TCL_MAJOR_VERSION >= 8
+ Tcl_Obj **av = (Tcl_Obj **)NULL;
+ Tcl_Obj *resultPtr;
+#else /* TCL_MAJOR_VERSION < 8 */
+ char **av = (char **)NULL;
+#endif
+
+ DUMP2("invoke_real called by thread:%lx", rb_thread_current());
+
+ /* get the data struct */
+ ptr = get_ip(interp);
+
+ /* ip is deleted? */
+ if (Tcl_InterpDeleted(ptr->ip)) {
+ DUMP1("ip is deleted");
+ return rb_tainted_str_new2("");
+ }
+
+ /* allocate memory for arguments */
+ av = alloc_invoke_arguments(argc, argv);
+
+ /* Invoke the C procedure */
+ Tcl_ResetResult(ptr->ip);
+ v = ip_invoke_core(interp, argc, av);
+
+ /* free allocated memory */
+ free_invoke_arguments(argc, av);
+
+ return v;
}
VALUE
@@ -2171,7 +4056,7 @@ ivq_safelevel_handler(arg, ivq)
Data_Get_Struct(ivq, struct invoke_queue, q);
DUMP2("(safe-level handler) $SAFE = %d", q->safe_level);
rb_set_safe_level(q->safe_level);
- return ip_invoke_real(q->argc, q->argv, q->obj);
+ return ip_invoke_core(q->interp, q->argc, q->argv);
}
int invoke_queue_handler _((Tcl_Event *, int));
@@ -2181,12 +4066,13 @@ invoke_queue_handler(evPtr, flags)
int flags;
{
struct invoke_queue *q = (struct invoke_queue *)evPtr;
+ volatile VALUE ret;
DUMP2("do_invoke_queue_handler : evPtr = %p", evPtr);
DUMP2("invoke queue_thread : %lx", rb_thread_current());
DUMP2("added by thread : %lx", q->thread);
- if (q->done) {
+ if (*(q->done)) {
DUMP1("processed by another event-loop");
return 0;
} else {
@@ -2194,20 +4080,26 @@ invoke_queue_handler(evPtr, flags)
}
/* process it */
- q->done = 1;
+ *(q->done) = 1;
/* check safe-level */
if (rb_safe_level() != q->safe_level) {
- *(q->result)
- = rb_funcall(rb_proc_new(ivq_safelevel_handler,
- Data_Wrap_Struct(rb_cData,0,0,q)),
- rb_intern("call"), 0);
+ volatile VALUE q_dat;
+ q_dat = Data_Wrap_Struct(rb_cData,invoke_queue_mark,0,q);
+ ret = rb_funcall(rb_proc_new(evq_safelevel_handler, q_dat),
+ ID_call, 0);
} else {
- DUMP2("call invoke_real (for caller thread:%lx)", q->thread);
- DUMP2("call invoke_real (current thread:%lx)", rb_thread_current());
- *(q->result) = ip_invoke_real(q->argc, q->argv, q->obj);
+ DUMP2("call invoke_real (for caller thread:%lx)", q->thread);
+ DUMP2("call invoke_real (current thread:%lx)", rb_thread_current());
+ ret = ip_invoke_core(q->interp, q->argc, q->argv);
}
+ /* set result */
+ RARRAY(q->result)->ptr[0] = ret;
+
+ /* complete */
+ *(q->done) = -1;
+
/* back to caller */
DUMP2("back to caller (caller thread:%lx)", q->thread);
DUMP2(" (current thread:%lx)", rb_thread_current());
@@ -2219,16 +4111,28 @@ invoke_queue_handler(evPtr, flags)
}
static VALUE
-ip_invoke(argc, argv, obj)
+ip_invoke_with_position(argc, argv, obj, position)
int argc;
VALUE *argv;
VALUE obj;
+ Tcl_QueuePosition position;
{
- struct invoke_queue *tmp;
+ struct invoke_queue *ivq;
+ char *s;
+ int len;
+ int i;
+ int *alloc_done;
+ int thr_crit_bup;
+ VALUE v;
VALUE current = rb_thread_current();
- VALUE result;
- VALUE *alloc_argv, *alloc_result;
- Tcl_QueuePosition position;
+ volatile VALUE result = rb_ary_new2(1);
+ volatile VALUE ret;
+
+#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");
@@ -2248,45 +4152,60 @@ ip_invoke(argc, argv, obj)
DUMP2("invoke from thread %lx (NOT current eventloop)", current);
- /* allocate memory (protected from Tcl_ServiceEvent) */
- alloc_argv = ALLOC_N(VALUE,argc);
- MEMCPY(alloc_argv, argv, VALUE, argc);
- alloc_result = ALLOC(VALUE);
+ 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 = 0;
/* allocate memory (freed by Tcl_ServiceEvent) */
- tmp = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue));
+ ivq = (struct invoke_queue *)Tcl_Alloc(sizeof(struct invoke_queue));
/* construct event data */
- tmp->done = 0;
- tmp->obj = obj;
- tmp->argc = argc;
- tmp->argv = alloc_argv;
- tmp->result = alloc_result;
- tmp->thread = current;
- tmp->safe_level = rb_safe_level();
- tmp->ev.proc = invoke_queue_handler;
- position = TCL_QUEUE_TAIL;
+ ivq->done = alloc_done;
+ ivq->argc = argc;
+ ivq->argv = av;
+ ivq->interp = 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");
- Tcl_QueueEvent(&(tmp->ev), position);
+ Tcl_QueueEvent(&(ivq->ev), position);
+
+ rb_thread_critical = thr_crit_bup;
/* wait for the handler to be processed */
DUMP2("wait for handler (current thread:%lx)", current);
- rb_thread_stop();
+ while(*alloc_done >= 0) {
+ rb_thread_stop();
+ }
DUMP2("back from handler (current thread:%lx)", current);
/* get result & free allocated memory */
- result = *alloc_result;
- free(alloc_argv);
- free(alloc_result);
- if (rb_obj_is_kind_of(result, rb_eException)) {
- rb_exc_raise(result);
+ ret = RARRAY(result)->ptr[0];
+ free(alloc_done);
+
+ /* 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);
}
- return result;
+ DUMP1("exit ip_invoke");
+ return ret;
}
+
/* get return code from Tcl_Eval() */
static VALUE
ip_retval(self)
@@ -2300,6 +4219,864 @@ ip_retval(self)
return (INT2FIX(ptr->return_value));
}
+static VALUE
+ip_invoke(argc, argv, obj)
+ int argc;
+ VALUE *argv;
+ VALUE obj;
+{
+ return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_TAIL);
+}
+
+static VALUE
+ip_invoke_immediate(argc, argv, obj)
+ int argc;
+ VALUE *argv;
+ VALUE obj;
+{
+ return ip_invoke_with_position(argc, argv, obj, TCL_QUEUE_HEAD);
+}
+
+/* access Tcl variables */
+static VALUE
+ip_get_variable(self, varname_arg, flag_arg)
+ VALUE self;
+ VALUE varname_arg;
+ VALUE flag_arg;
+{
+ struct tcltkip *ptr = get_ip(self);
+ int thr_crit_bup;
+ volatile VALUE varname, flag;
+
+ varname = varname_arg;
+ flag = flag_arg;
+
+ StringValue(varname);
+
+#if TCL_MAJOR_VERSION >= 8
+ {
+ Tcl_Obj *nameobj, *ret;
+ char *s;
+ int len;
+ VALUE strval;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ nameobj = Tcl_NewStringObj(RSTRING(varname)->ptr,
+ RSTRING(varname)->len);
+ Tcl_IncrRefCount(nameobj);
+
+ ret = Tcl_ObjGetVar2(ptr->ip, nameobj, (Tcl_Obj*)NULL, FIX2INT(flag));
+
+ Tcl_DecrRefCount(nameobj);
+
+ rb_thread_critical = thr_crit_bup;
+
+ if (ret == (Tcl_Obj*)NULL) {
+#if TCL_MAJOR_VERSION >= 8
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+#endif
+ }
+
+ Tcl_IncrRefCount(ret);
+
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ s = Tcl_GetStringFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ Tcl_DecrRefCount(ret);
+ return(strval);
+# else /* TCL_VERSION >= 8.1 */
+ {
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ if (Tcl_GetCharLength(ret)
+ != Tcl_UniCharLen(Tcl_GetUnicode(ret))) {
+ /* possibly binary string */
+ s = Tcl_GetByteArrayFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ rb_ivar_set(strval, ID_at_enc, rb_tainted_str_new2("binary"));
+ } else {
+ /* possibly text string */
+ s = Tcl_GetStringFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ }
+
+ rb_thread_critical = thr_crit_bup;
+ }
+
+ Tcl_DecrRefCount(ret);
+ return(strval);
+# endif
+ }
+#else /* TCL_MAJOR_VERSION < 8 */
+ {
+ char *ret;
+
+ ret = Tcl_GetVar2(ptr->ip, RSTRING(varname)->ptr,
+ (char*)NULL, FIX2INT(flag));
+ if (ret == (char*)NULL) {
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+ }
+ return(rb_tainted_str_new2(ret));
+ }
+#endif
+}
+
+static VALUE
+ip_get_variable2(self, varname_arg, index_arg, flag_arg)
+ VALUE self;
+ VALUE varname_arg;
+ VALUE index_arg;
+ VALUE flag_arg;
+{
+ struct tcltkip *ptr = get_ip(self);
+ int thr_crit_bup;
+ volatile VALUE varname, index, flag;
+
+ if (NIL_P(index_arg)) {
+ return ip_get_variable(self, varname_arg, flag_arg);
+ }
+
+ varname = varname_arg;
+ index = index_arg;
+ flag = flag_arg;
+
+ StringValue(varname);
+ StringValue(index);
+
+#if TCL_MAJOR_VERSION >= 8
+ {
+ Tcl_Obj *nameobj, *idxobj, *ret;
+ char *s;
+ int len;
+ volatile VALUE strval;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ nameobj = Tcl_NewStringObj(RSTRING(varname)->ptr,
+ RSTRING(varname)->len);
+ Tcl_IncrRefCount(nameobj);
+ idxobj = Tcl_NewStringObj(RSTRING(index)->ptr, RSTRING(index)->len);
+ Tcl_IncrRefCount(idxobj);
+
+ ret = Tcl_ObjGetVar2(ptr->ip, nameobj, idxobj, FIX2INT(flag));
+
+ Tcl_IncrRefCount(ret);
+ Tcl_DecrRefCount(nameobj);
+ Tcl_DecrRefCount(idxobj);
+
+ rb_thread_critical = thr_crit_bup;
+
+ if (ret == (Tcl_Obj*)NULL) {
+ Tcl_DecrRefCount(ret);
+#if TCL_MAJOR_VERSION >= 8
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+#endif
+ }
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ s = Tcl_GetStringFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ Tcl_DecrRefCount(ret);
+ return(strval);
+# else /* TCL_VERSION >= 8.1 */
+ {
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ if (Tcl_GetCharLength(ret)
+ != Tcl_UniCharLen(Tcl_GetUnicode(ret))) {
+ /* possibly binary string */
+ s = Tcl_GetByteArrayFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ rb_ivar_set(strval, ID_at_enc, rb_tainted_str_new2("binary"));
+ } else {
+ /* possibly text string */
+ s = Tcl_GetStringFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ }
+
+ rb_thread_critical = thr_crit_bup;
+ }
+
+ Tcl_DecrRefCount(ret);
+ return(strval);
+# endif
+ }
+#else /* TCL_MAJOR_VERSION < 8 */
+ {
+ char *ret;
+
+ ret = Tcl_GetVar2(ptr->ip, RSTRING(varname)->ptr, RSTRING(index)->ptr,
+ FIX2INT(flag));
+ if (ret == (char*)NULL) {
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+ }
+ return(rb_tainted_str_new2(ret));
+ }
+#endif
+}
+
+static VALUE
+ip_set_variable(self, varname_arg, value_arg, flag_arg)
+ VALUE self;
+ VALUE varname_arg;
+ VALUE value_arg;
+ VALUE flag_arg;
+{
+ struct tcltkip *ptr = get_ip(self);
+ int thr_crit_bup;
+ volatile VALUE varname, value, flag;
+
+ varname = varname_arg;
+ value = value_arg;
+ flag = flag_arg;
+
+ StringValue(varname);
+ StringValue(value);
+
+#if TCL_MAJOR_VERSION >= 8
+ {
+ Tcl_Obj *nameobj, *valobj, *ret;
+ char *s;
+ int len;
+ volatile VALUE strval;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ nameobj = Tcl_NewStringObj(RSTRING(varname)->ptr,
+ RSTRING(varname)->len);
+ Tcl_IncrRefCount(nameobj);
+
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ valobj = Tcl_NewStringObj(RSTRING(value)->ptr,
+ RSTRING(value)->len);
+ Tcl_IncrRefCount(valobj);
+# else /* TCL_VERSION >= 8.1 */
+ {
+ VALUE enc = rb_ivar_get(value, ID_at_enc);
+
+ if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) {
+ /* binary string */
+ valobj = Tcl_NewByteArrayObj(RSTRING(value)->ptr,
+ RSTRING(value)->len);
+ } else if (strlen(RSTRING(value)->ptr) != RSTRING(value)->len) {
+ /* probably binary string */
+ valobj = Tcl_NewByteArrayObj(RSTRING(value)->ptr,
+ RSTRING(value)->len);
+ } else {
+ /* probably text string */
+ valobj = Tcl_NewStringObj(RSTRING(value)->ptr,
+ RSTRING(value)->len);
+ }
+
+ Tcl_IncrRefCount(valobj);
+ }
+# endif
+
+ ret = Tcl_ObjSetVar2(ptr->ip, nameobj, (Tcl_Obj*)NULL, valobj,
+ FIX2INT(flag));
+
+ Tcl_DecrRefCount(nameobj);
+ Tcl_DecrRefCount(valobj);
+
+ if (ret == (Tcl_Obj*)NULL) {
+#if TCL_MAJOR_VERSION >= 8
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+#endif
+ }
+
+ Tcl_IncrRefCount(ret);
+
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ s = Tcl_GetStringFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+# else /* TCL_VERSION >= 8.1 */
+ if (Tcl_GetCharLength(ret) != Tcl_UniCharLen(Tcl_GetUnicode(ret))) {
+ /* possibly binary string */
+ s = Tcl_GetByteArrayFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ rb_ivar_set(strval, ID_at_enc, rb_str_new2("binary"));
+ } else {
+ /* possibly text string */
+ s = Tcl_GetStringFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ }
+# endif
+
+ rb_thread_critical = thr_crit_bup;
+
+ Tcl_DecrRefCount(ret);
+
+ return(strval);
+ }
+#else /* TCL_MAJOR_VERSION < 8 */
+ {
+ CONST char *ret;
+
+ ret = Tcl_SetVar2(ptr->ip, RSTRING(varname)->ptr, (char*)NULL,
+ RSTRING(value)->ptr, (int)FIX2INT(flag));
+ if (ret == NULL) {
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+ }
+ return(rb_tainted_str_new2(ret));
+ }
+#endif
+}
+
+static VALUE
+ip_set_variable2(self, varname_arg, index_arg, value_arg, flag_arg)
+ VALUE self;
+ VALUE varname_arg;
+ VALUE index_arg;
+ VALUE value_arg;
+ VALUE flag_arg;
+{
+ struct tcltkip *ptr = get_ip(self);
+ int thr_crit_bup;
+ volatile VALUE varname, index, value, flag;
+
+ if (NIL_P(index_arg)) {
+ return ip_set_variable(self, varname_arg, value_arg, flag_arg);
+ }
+
+ varname = varname_arg;
+ index = index_arg;
+ value = value_arg;
+ flag = flag_arg;
+
+ StringValue(varname);
+ StringValue(index);
+ StringValue(value);
+
+#if TCL_MAJOR_VERSION >= 8
+ {
+ Tcl_Obj *nameobj, *idxobj, *valobj, *ret;
+ char *s;
+ int len;
+ volatile VALUE strval;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ nameobj = Tcl_NewStringObj(RSTRING(varname)->ptr,
+ RSTRING(varname)->len);
+ Tcl_IncrRefCount(nameobj);
+
+ idxobj = Tcl_NewStringObj(RSTRING(index)->ptr,
+ RSTRING(index)->len);
+ Tcl_IncrRefCount(idxobj);
+
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ valobj = Tcl_NewStringObj(RSTRING(value)->ptr,
+ RSTRING(value)->len);
+# else /* TCL_VERSION >= 8.1 */
+ {
+ VALUE enc = rb_ivar_get(value, ID_at_enc);
+
+ if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) {
+ /* binary string */
+ valobj = Tcl_NewByteArrayObj(RSTRING(value)->ptr,
+ RSTRING(value)->len);
+ } else if (strlen(RSTRING(value)->ptr) != RSTRING(value)->len) {
+ /* probably binary string */
+ valobj = Tcl_NewByteArrayObj(RSTRING(value)->ptr,
+ RSTRING(value)->len);
+ } else {
+ /* probably text string */
+ valobj = Tcl_NewStringObj(RSTRING(value)->ptr,
+ RSTRING(value)->len);
+ }
+ }
+
+# endif
+ Tcl_IncrRefCount(valobj);
+
+ ret = Tcl_ObjSetVar2(ptr->ip, nameobj, idxobj, valobj, FIX2INT(flag));
+
+ Tcl_DecrRefCount(nameobj);
+ Tcl_DecrRefCount(idxobj);
+ Tcl_DecrRefCount(valobj);
+
+ rb_thread_critical = thr_crit_bup;
+
+ if (ret == (Tcl_Obj*)NULL) {
+#if TCL_MAJOR_VERSION >= 8
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+#endif
+ }
+
+ Tcl_IncrRefCount(ret);
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ s = Tcl_GetStringFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+# else /* TCL_VERSION >= 8.1 */
+ if (Tcl_GetCharLength(ret) != Tcl_UniCharLen(Tcl_GetUnicode(ret))) {
+ /* possibly binary string */
+ s = Tcl_GetByteArrayFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ rb_ivar_set(strval, ID_at_enc, rb_str_new2("binary"));
+ } else {
+ /* possibly text string */
+ s = Tcl_GetStringFromObj(ret, &len);
+ strval = rb_tainted_str_new(s, len);
+ }
+# endif
+
+ rb_thread_critical = thr_crit_bup;
+
+ Tcl_DecrRefCount(ret);
+
+ return(strval);
+ }
+#else /* TCL_MAJOR_VERSION < 8 */
+ {
+ CONST char *ret;
+
+ ret = Tcl_SetVar2(ptr->ip, RSTRING(varname)->ptr, RSTRING(index)->ptr,
+ RSTRING(value)->ptr, FIX2INT(flag));
+ if (ret == (char*)NULL) {
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+ }
+ return(rb_tainted_str_new2(ret));
+ }
+#endif
+}
+
+static VALUE
+ip_unset_variable(self, varname_arg, flag_arg)
+ VALUE self;
+ VALUE varname_arg;
+ VALUE flag_arg;
+{
+ struct tcltkip *ptr = get_ip(self);
+ volatile VALUE varname, value, flag;
+
+ varname = varname_arg;
+ flag = flag_arg;
+
+ StringValue(varname);
+ ptr->return_value = Tcl_UnsetVar(ptr->ip, RSTRING(varname)->ptr,
+ FIX2INT(flag));
+ if (ptr->return_value == TCL_ERROR) {
+ if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) {
+#if TCL_MAJOR_VERSION >= 8
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+#endif
+ }
+ return Qfalse;
+ }
+ return Qtrue;
+}
+
+static VALUE
+ip_unset_variable2(self, varname_arg, index_arg, flag_arg)
+ VALUE self;
+ VALUE varname_arg;
+ VALUE index_arg;
+ VALUE flag_arg;
+{
+ struct tcltkip *ptr = get_ip(self);
+ volatile VALUE varname, index, value, flag;
+
+ if (NIL_P(index_arg)) {
+ return ip_unset_variable(self, varname_arg, flag_arg);
+ }
+
+ varname = varname_arg;
+ index = index_arg;
+ flag = flag_arg;
+
+ StringValue(varname);
+ StringValue(index);
+
+ ptr->return_value = Tcl_UnsetVar2(ptr->ip, RSTRING(varname)->ptr,
+ RSTRING(index)->ptr, FIX2INT(flag));
+ if (ptr->return_value == TCL_ERROR) {
+ if (FIX2INT(flag) & TCL_LEAVE_ERR_MSG) {
+#if TCL_MAJOR_VERSION >= 8
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(ptr->ip));
+#else /* TCL_MAJOR_VERSION < 8 */
+ rb_raise(rb_eRuntimeError, "%s", ptr->ip->result);
+#endif
+ }
+ return Qfalse;
+ }
+ return Qtrue;
+}
+
+static VALUE
+ip_get_global_var(self, varname)
+ VALUE self;
+ VALUE varname;
+{
+ return ip_get_variable(self, varname,
+ INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
+}
+
+static VALUE
+ip_get_global_var2(self, varname, index)
+ VALUE self;
+ VALUE varname;
+ VALUE index;
+{
+ return ip_get_variable2(self, varname, index,
+ INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
+}
+
+static VALUE
+ip_set_global_var(self, varname, value)
+ VALUE self;
+ VALUE varname;
+ VALUE value;
+{
+ return ip_set_variable(self, varname, value,
+ INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
+}
+
+static VALUE
+ip_set_global_var2(self, varname, index, value)
+ VALUE self;
+ VALUE varname;
+ VALUE index;
+ VALUE value;
+{
+ return ip_set_variable2(self, varname, index, value,
+ INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
+}
+
+static VALUE
+ip_unset_global_var(self, varname)
+ VALUE self;
+ VALUE varname;
+{
+ return ip_unset_variable(self, varname,
+ INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
+}
+
+static VALUE
+ip_unset_global_var2(self, varname, index)
+ VALUE self;
+ VALUE varname;
+ VALUE index;
+{
+ return ip_unset_variable2(self, varname, index,
+ INT2FIX(TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG));
+}
+
+
+/* treat Tcl_List */
+static VALUE
+lib_split_tklist_core(ip_obj, list_str)
+ VALUE ip_obj;
+ VALUE list_str;
+{
+ Tcl_Interp *interp;
+ volatile VALUE ary, elem;
+ int idx;
+ int taint_flag = OBJ_TAINTED(list_str);
+ int result;
+ VALUE old_gc;
+
+ if (NIL_P(ip_obj)) {
+ interp = (Tcl_Interp *)NULL;
+ } else {
+ interp = get_ip(ip_obj)->ip;
+ }
+
+ StringValue(list_str);
+
+ {
+#if TCL_MAJOR_VERSION >= 8
+ /* object style interface */
+ Tcl_Obj *listobj;
+ int objc;
+ Tcl_Obj **objv;
+ int thr_crit_bup;
+
+# if 1
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ listobj = Tcl_NewStringObj(RSTRING(list_str)->ptr,
+ RSTRING(list_str)->len);
+# else /* TCL_VERSION >= 8.1 */
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ {
+ VALUE enc = rb_ivar_get(list_str, ID_at_enc);
+
+ if (!NIL_P(enc) && strcmp(StringValuePtr(enc), "binary") == 0) {
+ /* binary string */
+ listobj = Tcl_NewByteArrayObj(RSTRING(list_str)->ptr,
+ RSTRING(list_str)->len);
+ } else if (strlen(RSTRING(list_str)->ptr)
+ != RSTRING(list_str)->len) {
+ /* probably binary string */
+ listobj = Tcl_NewByteArrayObj(RSTRING(list_str)->ptr,
+ RSTRING(list_str)->len);
+ } else {
+ /* probably text string */
+ listobj = Tcl_NewStringObj(RSTRING(list_str)->ptr,
+ RSTRING(list_str)->len);
+ }
+ }
+
+ rb_thread_critical = thr_crit_bup;
+# endif
+# else
+ listobj = Tcl_NewStringObj(RSTRING(list_str)->ptr,
+ RSTRING(list_str)->len);
+# endif
+
+ Tcl_IncrRefCount(listobj);
+
+ result = Tcl_ListObjGetElements(interp, listobj, &objc, &objv);
+
+ if (result == TCL_ERROR) {
+ Tcl_DecrRefCount(listobj);
+ if (interp == (Tcl_Interp*)NULL) {
+ rb_raise(rb_eRuntimeError, "cannot get elements from list");
+ } else {
+#if TCL_MAJOR_VERSION >= 8
+ rb_raise(rb_eRuntimeError, "%s", Tcl_GetStringResult(interp));
+#else /* TCL_MAJOR_VERSION < 8 */
+ rb_raise(rb_eRuntimeError, "%s", interp->result);
+#endif
+ }
+ }
+
+ for(idx = 0; idx < objc; idx++) {
+ Tcl_IncrRefCount(objv[idx]);
+ }
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ ary = rb_ary_new2(objc);
+ if (taint_flag) OBJ_TAINT(ary);
+
+ old_gc = rb_gc_disable();
+
+ for(idx = 0; idx < objc; idx++) {
+ char *str;
+ int len;
+
+# if 1
+# if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION == 0
+ str = Tcl_GetStringFromObj(objv[idx], &len);
+ elem = rb_str_new(str, len);
+# else /* TCL_VERSION >= 8.1 */
+ if (Tcl_GetCharLength(objv[idx])
+ != Tcl_UniCharLen(Tcl_GetUnicode(objv[idx]))) {
+ /* possibly binary string */
+ str = Tcl_GetByteArrayFromObj(objv[idx], &len);
+ elem = rb_str_new(str, len);
+ rb_ivar_set(elem, ID_at_enc, rb_tainted_str_new2("binary"));
+ } else {
+ /* possibly text string */
+ str = Tcl_GetStringFromObj(objv[idx], &len);
+ elem = rb_str_new(str, len);
+ }
+# endif
+# else
+ str = Tcl_GetStringFromObj(objv[idx], &len);
+ elem = rb_str_new(str, len);
+# endif
+
+ if (taint_flag) OBJ_TAINT(elem);
+ RARRAY(ary)->ptr[idx] = elem;
+ }
+
+ RARRAY(ary)->len = objc;
+
+ if (old_gc == Qfalse) rb_gc_enable();
+
+ rb_thread_critical = thr_crit_bup;
+
+ for(idx = 0; idx < objc; idx++) {
+ Tcl_DecrRefCount(objv[idx]);
+ }
+
+ Tcl_DecrRefCount(listobj);
+
+#else /* TCL_MAJOR_VERSION < 8 */
+ /* string style interface */
+ int argc;
+ char **argv;
+
+ if (Tcl_SplitList(interp, RSTRING(list_str)->ptr,
+ &argc, &argv) == TCL_ERROR) {
+ if (interp == (Tcl_Interp*)NULL) {
+ rb_raise(rb_eRuntimeError, "cannot get elements from list");
+ } else {
+ rb_raise(rb_eRuntimeError, "%s", interp->result);
+ }
+ }
+
+ ary = rb_ary_new2(argc);
+ if (taint_flag) OBJ_TAINT(ary);
+
+ old_gc = rb_gc_disable();
+
+ for(idx = 0; idx < argc; idx++) {
+ if (taint_flag) {
+ elem = rb_tainted_str_new2(argv[idx]);
+ } else {
+ elem = rb_str_new2(argv[idx]);
+ }
+ /* rb_ivar_set(elem, ID_at_enc, rb_str_new2("binary")); */
+ RARRAY(ary)->ptr[idx] = elem;
+ }
+ RARRAY(ary)->len = argc;
+
+ if (old_gc == Qfalse) rb_gc_enable();
+#endif
+ }
+
+ return ary;
+}
+
+static VALUE
+lib_split_tklist(self, list_str)
+ VALUE self;
+ VALUE list_str;
+{
+ return lib_split_tklist_core(Qnil, list_str);
+}
+
+
+static VALUE
+ip_split_tklist(self, list_str)
+ VALUE self;
+ VALUE list_str;
+{
+ return lib_split_tklist_core(self, list_str);
+}
+
+static VALUE
+lib_merge_tklist(argc, argv, obj)
+ int argc;
+ VALUE *argv;
+ VALUE obj;
+{
+ int num, len;
+ int *flagPtr;
+ char *dst, *result;
+ volatile VALUE str;
+ int taint_flag = 0;
+ int thr_crit_bup;
+ VALUE old_gc;
+
+ if (argc == 0) return rb_str_new2("");
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+ old_gc = rb_gc_disable();
+
+ /* based on Tcl/Tk's Tcl_Merge() */
+ flagPtr = ALLOC_N(unsigned, argc);
+
+ /* pass 1 */
+ len = 1;
+ for(num = 0; num < argc; num++) {
+ if (OBJ_TAINTED(argv[num])) taint_flag = 1;
+ dst = StringValuePtr(argv[num]);
+#if TCL_MAJOR_VERSION >= 8
+ len += Tcl_ScanCountedElement(dst, RSTRING(argv[num])->len,
+ &flagPtr[num]) + 1;
+#else /* TCL_MAJOR_VERSION < 8 */
+ len += Tcl_ScanElement(dst, &flagPtr[num]) + 1;
+#endif
+ }
+
+ /* pass 2 */
+ result = (char *)Tcl_Alloc(len);
+ dst = result;
+ for(num = 0; num < argc; num++) {
+#if TCL_MAJOR_VERSION >= 8
+ len = Tcl_ConvertCountedElement(RSTRING(argv[num])->ptr,
+ RSTRING(argv[num])->len,
+ dst, flagPtr[num]);
+#else /* TCL_MAJOR_VERSION < 8 */
+ len = Tcl_ConvertElement(RSTRING(argv[num])->ptr, dst, flagPtr[num]);
+#endif
+ dst += len;
+ *dst = ' ';
+ dst++;
+ }
+ if (dst == result) {
+ *dst = 0;
+ } else {
+ dst[-1] = 0;
+ }
+
+ free(flagPtr);
+
+ /* create object */
+ str = rb_str_new(result, dst - result - 1);
+ if (taint_flag) OBJ_TAINT(str);
+ Tcl_Free(result);
+
+ if (old_gc == Qfalse) rb_gc_enable();
+ rb_thread_critical = thr_crit_bup;
+
+ return str;
+}
+
+static VALUE
+lib_conv_listelement(self, src)
+ VALUE self;
+ VALUE src;
+{
+ int len, scan_flag;
+ volatile VALUE dst;
+ int taint_flag = OBJ_TAINTED(src);
+ int thr_crit_bup;
+
+ thr_crit_bup = rb_thread_critical;
+ rb_thread_critical = Qtrue;
+
+ StringValue(src);
+
+#if TCL_MAJOR_VERSION >= 8
+ len = Tcl_ScanCountedElement(RSTRING(src)->ptr, RSTRING(src)->len,
+ &scan_flag);
+ dst = rb_str_new(0, len + 1);
+ len = Tcl_ConvertCountedElement(RSTRING(src)->ptr, RSTRING(src)->len,
+ RSTRING(dst)->ptr, scan_flag);
+#else /* TCL_MAJOR_VERSION < 8 */
+ len = Tcl_ScanElement(RSTRING(src)->ptr, &scan_flag);
+ dst = rb_str_new(0, len + 1);
+ len = Tcl_ConvertElement(RSTRING(src)->ptr, RSTRING(dst)->ptr, scan_flag);
+#endif
+
+ RSTRING(dst)->len = len;
+ RSTRING(dst)->ptr[len] = '\0';
+ if (taint_flag) OBJ_TAINT(dst);
+
+ rb_thread_critical = thr_crit_bup;
+
+ return dst;
+}
+
+
#ifdef __MACOS__
static void
_macinit()
@@ -2313,18 +5090,40 @@ _macinit()
void
Init_tcltklib()
{
+ int thr_crit_bup;
+
VALUE lib = rb_define_module("TclTkLib");
VALUE ip = rb_define_class("TclTkIp", rb_cObject);
VALUE ev_flag = rb_define_module_under(lib, "EventFlag");
+ VALUE var_flag = rb_define_module_under(lib, "VarAccessFlag");
+
+ /* --------------------------------------------------------------- */
#if defined USE_TCL_STUBS && defined USE_TK_STUBS
extern int ruby_tcltk_stubs();
int ret = ruby_tcltk_stubs();
+
if (ret)
rb_raise(rb_eLoadError, "tcltklib: tcltk_stubs init error(%d)", ret);
#endif
+ /* --------------------------------------------------------------- */
+
+ rb_global_variable(&eTkCallbackReturn);
+ rb_global_variable(&eTkCallbackBreak);
+ rb_global_variable(&eTkCallbackContinue);
+
+ rb_global_variable(&eventloop_thread);
+ rb_global_variable(&watchdog_thread);
+
+ /* --------------------------------------------------------------- */
+
+ rb_define_const(lib, "FINALIZE_PROC_NAME",
+ rb_str_new2(finalize_hook_name));
+
+ /* --------------------------------------------------------------- */
+
rb_define_const(ev_flag, "NONE", INT2FIX(0));
rb_define_const(ev_flag, "WINDOW", INT2FIX(TCL_WINDOW_EVENTS));
rb_define_const(ev_flag, "FILE", INT2FIX(TCL_FILE_EVENTS));
@@ -2333,10 +5132,56 @@ Init_tcltklib()
rb_define_const(ev_flag, "ALL", INT2FIX(TCL_ALL_EVENTS));
rb_define_const(ev_flag, "DONT_WAIT", INT2FIX(TCL_DONT_WAIT));
+ /* --------------------------------------------------------------- */
+
+ rb_define_const(var_flag, "NONE", INT2FIX(0));
+ rb_define_const(var_flag, "GLOBAL_ONLY", INT2FIX(TCL_GLOBAL_ONLY));
+#ifdef TCL_NAMESPACE_ONLY
+ rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(TCL_NAMESPACE_ONLY));
+#else /* probably Tcl7.6 */
+ rb_define_const(var_flag, "NAMESPACE_ONLY", INT2FIX(0));
+#endif
+ rb_define_const(var_flag, "LEAVE_ERR_MSG", INT2FIX(TCL_LEAVE_ERR_MSG));
+ rb_define_const(var_flag, "APPEND_VALUE", INT2FIX(TCL_APPEND_VALUE));
+ rb_define_const(var_flag, "LIST_ELEMENT", INT2FIX(TCL_LIST_ELEMENT));
+#ifdef TCL_PARSE_PART1
+ rb_define_const(var_flag, "PARSE_VARNAME", INT2FIX(TCL_PARSE_PART1));
+#else /* probably Tcl7.6 */
+ rb_define_const(var_flag, "PARSE_VARNAME", INT2FIX(0));
+#endif
+
+ /* --------------------------------------------------------------- */
+
+ eTkCallbackBreak = rb_define_class("TkCallbackReturn", rb_eStandardError);
eTkCallbackBreak = rb_define_class("TkCallbackBreak", rb_eStandardError);
eTkCallbackContinue = rb_define_class("TkCallbackContinue",
rb_eStandardError);
+ /* --------------------------------------------------------------- */
+
+ eLocalJumpError = rb_const_get(rb_cObject, rb_intern("LocalJumpError"));
+
+ ID_at_enc = rb_intern("@encoding");
+ ID_at_interp = rb_intern("@interp");
+
+ ID_stop_p = rb_intern("stop?");
+ ID_kill = rb_intern("kill");
+ ID_join = rb_intern("join");
+
+ ID_call = rb_intern("call");
+ ID_backtrace = rb_intern("backtrace");
+ ID_message = rb_intern("message");
+
+ ID_at_reason = rb_intern("@reason");
+ ID_return = rb_intern("return");
+ ID_break = rb_intern("break");
+ ID_next = rb_intern("next");
+
+ ID_to_s = rb_intern("to_s");
+ ID_inspect = rb_intern("inspect");
+
+ /* --------------------------------------------------------------- */
+
rb_define_module_function(lib, "mainloop", lib_mainloop, -1);
rb_define_module_function(lib, "mainloop_watchdog",
lib_mainloop_watchdog, -1);
@@ -2351,11 +5196,27 @@ Init_tcltklib()
rb_define_module_function(lib, "get_no_event_wait", get_no_event_wait, 0);
rb_define_module_function(lib, "set_eventloop_weight",
set_eventloop_weight, 2);
+ rb_define_module_function(lib, "set_max_block_time", set_max_block_time,1);
rb_define_module_function(lib, "get_eventloop_weight",
get_eventloop_weight, 0);
rb_define_module_function(lib, "num_of_mainwindows",
lib_num_of_mainwindows, 0);
+ /* --------------------------------------------------------------- */
+
+ rb_define_module_function(lib, "_split_tklist", lib_split_tklist, 1);
+ rb_define_module_function(lib, "_merge_tklist", lib_merge_tklist, -1);
+ rb_define_module_function(lib, "_conv_listelement",
+ lib_conv_listelement, 1);
+ rb_define_module_function(lib, "_toUTF8", lib_toUTF8, -1);
+ rb_define_module_function(lib, "_fromUTF8", lib_fromUTF8, -1);
+ rb_define_module_function(lib, "_subst_UTF_backslash",
+ lib_UTF_backslash, 1);
+ rb_define_module_function(lib, "_subst_Tcl_backslash",
+ lib_Tcl_backslash, 1);
+
+ /* --------------------------------------------------------------- */
+
rb_define_alloc_func(ip, ip_alloc);
rb_define_method(ip, "initialize", ip_init, -1);
rb_define_method(ip, "create_slave", ip_create_slave, -1);
@@ -2364,13 +5225,36 @@ Init_tcltklib()
rb_define_method(ip, "delete", ip_delete, 0);
rb_define_method(ip, "deleted?", ip_is_deleted_p, 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, "_toUTF8", ip_toUTF8, -1);
+ rb_define_method(ip, "_fromUTF8", ip_fromUTF8, -1);
rb_define_method(ip, "_thread_vwait", ip_thread_vwait, 1);
rb_define_method(ip, "_thread_tkwait", ip_thread_tkwait, 2);
rb_define_method(ip, "_invoke", ip_invoke, -1);
rb_define_method(ip, "_return_value", ip_retval, 0);
+ /* --------------------------------------------------------------- */
+
+ rb_define_method(ip, "_get_variable", ip_get_variable, 2);
+ rb_define_method(ip, "_get_variable2", ip_get_variable2, 3);
+ rb_define_method(ip, "_set_variable", ip_set_variable, 3);
+ rb_define_method(ip, "_set_variable2", ip_set_variable2, 4);
+ rb_define_method(ip, "_unset_variable", ip_unset_variable, 2);
+ rb_define_method(ip, "_unset_variable2", ip_unset_variable2, 3);
+ rb_define_method(ip, "_get_global_var", ip_get_global_var, 1);
+ rb_define_method(ip, "_get_global_var2", ip_get_global_var2, 2);
+ rb_define_method(ip, "_set_global_var", ip_set_global_var, 2);
+ rb_define_method(ip, "_set_global_var2", ip_set_global_var2, 3);
+ rb_define_method(ip, "_unset_global_var", ip_unset_global_var, 1);
+ rb_define_method(ip, "_unset_global_var2", ip_unset_global_var2, 2);
+
+ /* --------------------------------------------------------------- */
+
+ rb_define_method(ip, "_split_tklist", ip_split_tklist, 1);
+ rb_define_method(ip, "_merge_tklist", lib_merge_tklist, -1);
+ rb_define_method(ip, "_conv_listelement", lib_conv_listelement, 1);
+
+ /* --------------------------------------------------------------- */
+
rb_define_method(ip, "mainloop", ip_mainloop, -1);
rb_define_method(ip, "mainloop_watchdog", ip_mainloop_watchdog, -1);
rb_define_method(ip, "do_one_event", ip_do_one_event, -1);
@@ -2384,19 +5268,25 @@ Init_tcltklib()
rb_define_method(ip, "get_no_event_wait", ip_get_no_event_wait, 0);
rb_define_method(ip, "set_eventloop_weight", ip_set_eventloop_weight, 2);
rb_define_method(ip, "get_eventloop_weight", ip_get_eventloop_weight, 0);
+ rb_define_method(ip, "set_max_block_time", set_max_block_time, 1);
rb_define_method(ip, "restart", ip_restart, 0);
+ /* --------------------------------------------------------------- */
+
eventloop_thread = 0;
watchdog_thread = 0;
+ /* --------------------------------------------------------------- */
+
#ifdef __MACOS__
_macinit();
#endif
- /*---- initialize tcl/tk libraries ----*/
/* from Tk_Main() */
DUMP1("Tcl_FindExecutable");
Tcl_FindExecutable(RSTRING(rb_argv0)->ptr);
+
+ /* --------------------------------------------------------------- */
}
/* eof */