summaryrefslogtreecommitdiff
path: root/ext/tcltklib
diff options
context:
space:
mode:
Diffstat (limited to 'ext/tcltklib')
-rw-r--r--ext/tcltklib/MANIFEST15
-rw-r--r--ext/tcltklib/MANUAL.euc124
-rw-r--r--ext/tcltklib/README.euc133
-rw-r--r--ext/tcltklib/demo/lines0.tcl42
-rw-r--r--ext/tcltklib/demo/lines1.rb54
-rw-r--r--ext/tcltklib/demo/lines2.rb50
-rw-r--r--ext/tcltklib/depend1
-rw-r--r--ext/tcltklib/extconf.rb79
-rw-r--r--ext/tcltklib/lib/tcltk.rb388
-rw-r--r--ext/tcltklib/sample/batsu.gifbin0 -> 538 bytes
-rw-r--r--ext/tcltklib/sample/maru.gifbin0 -> 481 bytes
-rw-r--r--ext/tcltklib/sample/sample0.rb39
-rw-r--r--ext/tcltklib/sample/sample1.rb634
-rw-r--r--ext/tcltklib/sample/sample2.rb449
-rw-r--r--ext/tcltklib/tcltklib.c216
15 files changed, 2224 insertions, 0 deletions
diff --git a/ext/tcltklib/MANIFEST b/ext/tcltklib/MANIFEST
new file mode 100644
index 0000000000..b5e88278e0
--- /dev/null
+++ b/ext/tcltklib/MANIFEST
@@ -0,0 +1,15 @@
+MANIFEST
+README.euc
+MANUAL.euc
+tcltklib.c
+depend
+extconf.rb
+lib/tcltk.rb
+demo/lines1.rb
+demo/lines0.tcl
+demo/lines2.rb
+sample/sample1.rb
+sample/sample2.rb
+sample/maru.gif
+sample/batsu.gif
+sample/sample0.rb
diff --git a/ext/tcltklib/MANUAL.euc b/ext/tcltklib/MANUAL.euc
new file mode 100644
index 0000000000..789e85a9de
--- /dev/null
+++ b/ext/tcltklib/MANUAL.euc
@@ -0,0 +1,124 @@
+(tof)
+ MANUAL.euc
+ Sep. 19, 1997 Y. Shigehiro
+
+�ʲ�, ��tcl/tk�פȤ���ɽ����, tclsh �� wish ��¸����Ƥ���, ���̤Ǥ���
+�Ȥ����� tcl/tk ��ؤ��ޤ�. ��tcltk �饤�֥���, ��tcltklib �饤�֥�
+��פȤ���ɽ����, �ܥѥå������˴ޤޤ�� ruby �ѤΥ饤�֥���ؤ��ޤ�.
+
+<< tcltk �饤�֥�� >>
+
+tcl/tk �� C �饤�֥������Ѥ��뤿��ι�(��?)��।�󥿡��ե���������
+�����ޤ�.
+
+���Υ饤�֥��� ruby ���� tcl/tk �饤�֥������Ѥ��뤿��Τ�Τ�, ��
+���� tcltklib �饤�֥������Ѥ��Ƥ��ޤ�.
+
+[����]
+
+tcl/tk ���󥿥ץ꥿�Ǥ�, ���������åȤ˲����ؼ�������ˤ�, ����������
+��̾��³���ƥѥ�᡼����񤭤ޤ�. �������ä�, ���������åȤ����֥�����
+�ȤǤ���, ������Ф��ƥ᥽�åɤ����äƤ���, �Ȥߤʤ����Ȥ��Ǥ��ޤ�. ��
+��, tcl/tk ���󥿥ץ꥿�Ǥ�, �Ȥ߹��ߥ��ޥ�ɤ�, ���ҤΥ��������åȤ�
+Ʊ���褦�ʽ񼰤�̿��Ǽ¹Ԥ���ޤ�. ���ʤ��, ���ޥ�ɤ⥪�֥������Ȥ�
+����ȹͤ��뤳�Ȥ��Ǥ��ޤ�.
+
+���Τ褦�ʹͤ��˴�Ť�, tcltk �饤�֥��Ǥ�, tcl/tk �Υ��ޥ�ɤ䥦��
+�����åȤ��б����륪�֥������Ȥ��������ޤ�. ���֥������Ȥ��Ф���᥽��
+�ɸƤӽФ���, e() �᥽�åɤˤ��¹Ԥ���ޤ�. �㤨��, tcl/tk �� info
+���ޥ�ɤ��б����� ruby �Υ��֥������Ȥ� info �Ȥ���̾���Ǥ���Ȥ����,
+tcl/tk ��
+ info commands
+�Ȥ���̿��� tcltk �饤�֥��Ǥ�
+ info.e("commands")
+�ȵ��Ҥ���ޤ�. �ޤ�, ��.�פȤ������������å� (wish �¹Ի��˼�ưŪ����
+�������롼�ȥ��������å�) ���б����� ruby �Υ��֥������Ȥ� root �Ȥ�
+��̾���Ǥ���Ȥ����,
+ . configure -height 300 -width 300
+�Ȥ��� tcl/tk ��̿���
+ root.e("configure -height 300 -width 300")
+�ȵ��Ҥ���ޤ�. ���Τ褦�ʵ��Ҥ�, ������ˤ�����������ޤ���, ������,
+������ץȤ��ɤ�ͤˤϸ��Ť餤�����Τ�ޤ���, �ºݤ˥�����ץȤ��
+�Ƥߤ��ͽ�۳��˼�ڤǤ�.
+
+[����ˡ]
+
+1. �饤�֥����ɤ߹���.
+ require "tcltk"
+
+2. tcl/tk ���󥿥ץ꥿����������.
+ ip = TclTkInterpreter.new()
+
+3. tcl/tk �Υ��ޥ�ɤ��б����륪�֥������Ȥ��ѿ����������Ƥ���.
+ # ���ޥ�ɤ��б����륪�֥������Ȥ����ä� Hash ����Ф�.
+ c = ip.commands()
+ # �Ȥ��������ޥ�ɤ��б����륪�֥������Ȥ���̤��ѿ�����������.
+ bind, button, info, wm = c.indexes("bind", "button", "info", "wm")
+
+4. ɬ�פʽ�����Ԥ�.
+ �ܤ�����, ����ץ�򻲾ȤΤ���.
+
+5. �������Ǥ�����, ���٥�ȥ롼�פ�����.
+ TclTk.mainloop()
+
+(( �ʲ�, �⥸�塼��, ���饹�����������ͽ��.))
+
+
+
+<< tcltklib �饤�֥�� >>
+
+tcl/tk �� C �饤�֥������Ѥ��뤿������।�󥿡��ե��������󶡤���
+��.
+
+����ѥ���/�¹Ԥˤ�, tcl/tk �� C �饤�֥�꤬ɬ�פǤ�.
+
+[����]
+
+���Υ饤�֥����Ѥ����, ruby ���� tcl/tk �� C �饤�֥������ѤǤ���
+��. ����Ū�ˤ�, ruby ���󥿥ץ꥿���� tcl/tk ���󥿥ץ꥿��ƤӽФ���
+�Ȥ��Ǥ��ޤ�. �����, ����(ruby ���󥿥ץ꥿����ƤӽФ���) tcl/tk ��
+�󥿥ץ꥿����, �դ� ruby ���󥿥ץ꥿��ƤӽФ����Ȥ�Ǥ��ޤ�.
+
+[����ˡ]
+
+require "tcltklib" �����, �ʲ��Υ⥸�塼��, ���饹�����Ѳ�ǽ�Ǥ�.
+
+�⥸�塼�� TclTkLib
+ tcl/tk �饤�֥���ƤӽФ��᥽�åɤ򽸤᤿�⥸�塼��Ǥ�. ������,
+ tcl/tk ���󥿥ץ꥿�ط��Υ᥽�åɤϥ��饹 TclTkIp �ˤ���ޤ�.
+
+ �⥸�塼��᥽�å� mainloop()
+ Tk_MainLoop ��¹Ԥ��ޤ�. ���Ƥ� tk �Υ�����ɥ���̵���ʤ�Ƚ�λ
+ ���ޤ�(�㤨��, tcl/tk �ǽ񤯤Ȥ����� "destroy ." �򤷤������).
+ ����: ̵��
+ �����: nil
+
+���饹 TclTkIp
+ ���󥹥��󥹤� tcl/tk �Υ��󥿥ץ꥿���б����ޤ�. tcl/tk �Υ饤��
+ ���λ����̤�, ���󥹥��󥹤�ʣ�����������Ƥ�������ư��ޤ�(��
+ ��ʤ��Ȥ򤹤�ɬ�פϤ��ޤ�̵���Ϥ��Ǥ���). ���󥿥ץ꥿�� wish ��
+ tcl/tk ���ޥ�ɤ�¹ԤǤ��ޤ�. �����, �ʲ��Υ��ޥ�ɤ�¹ԤǤ���
+ ��.
+ ���ޥ�� ruby
+ ������ ruby �Ǽ¹Ԥ��ޤ�(ruby_eval_string ��¹Ԥ��ޤ�). ����
+ �� 1 �ĤǤʤ���Фʤ�ޤ���. ����ͤ� ruby �μ¹Է�̤Ǥ�.
+ ruby �μ¹Է�̤� nil �� String �Ǥʤ���Фʤ�ޤ���.
+
+ ���饹�᥽�å� new()
+ TclTkIp ���饹�Υ��󥹥��󥹤��������ޤ�
+ ����: ̵��
+ ����� (TclTkIp): �������줿���󥹥���
+
+ �᥽�å� _eval(script)
+ ���󥿥ץ꥿�� script ��ɾ�����ޤ�(Tcl_Eval ��¹Ԥ��ޤ�). ����
+ �Τ褦��, ruby ���ޥ�ɤˤ�� script �⤫�� ruby ������ץȤ��
+ �ԤǤ��ޤ�.
+ ����: script (String) - ���󥿥ץ꥿��ɾ�����륹����ץ�ʸ����
+ ����� (String): ɾ����� ((Tcl_Interp *)->result)
+
+ �᥽�å� _return_value()
+ ľ���� Tcl_Eval ������ͤ��֤��ޤ�. 0(TCL_OK) �����ェλ�Ǥ�.
+ ����: ̵��
+ ����� (Fixnum): ľ���� Tcl_Eval() ���֤�����.
+
+(eof)
diff --git a/ext/tcltklib/README.euc b/ext/tcltklib/README.euc
new file mode 100644
index 0000000000..290ffb0b60
--- /dev/null
+++ b/ext/tcltklib/README.euc
@@ -0,0 +1,133 @@
+(tof)
+ tcltk �饤�֥��
+ tcltklib �饤�֥��
+ Sep. 19, 1997 Y. Shigehiro
+
+�ʲ�, ��tcl/tk�פȤ���ɽ����, tclsh �� wish ��¸����Ƥ���, ���̤Ǥ���
+�Ȥ����� tcl/tk ��ؤ��ޤ�. ��tcltk �饤�֥���, ��tcltklib �饤�֥�
+��פȤ���ɽ����, �ܥѥå������˴ޤޤ�� ruby �ѤΥ饤�֥���ؤ��ޤ�.
+
+[�ե�����ˤĤ���]
+
+README.euc : ���Υե�����(����, ��ħ, ���󥹥ȡ������ˡ).
+MANUAL.euc : �ޥ˥奢��.
+
+lib/, ext/ : �饤�֥��μ���.
+
+sample/ : �ޥ˥奢������Υ���ץ�ץ������.
+sample/sample0.rb : tcltklib �饤�֥��Υƥ���.
+sample/sample1.rb : tcltk �饤�֥��Υƥ���.
+ tcl/tk (wish) �ǤǤ������ʤ��Ȥ���̤�񤤤Ƥߤޤ���.
+sample/sample2.rb : tcltk �饤�֥��Υ���ץ�.
+ maeda shugo ([email protected]) ��ˤ��
+ (`rb.tk' �ǽ񤫤�Ƥ���) ruby �Υ���ץ�ץ������
+ http://www.aianet.or.jp/~shugo/ruby/othello.rb.gz
+ �� tcltk �饤�֥���Ȥ��褦��, ����Ū���ѹ����Ƥߤޤ���.
+
+demo/ : 100 �ܤ����� 100 �������ǥ�ץ������.
+ �ǽ�˶��롼�פλ��֤�¬�ꤷ, ³���Ƽºݤ�����������֤�¬�ꤷ�ޤ�.
+ tcl/tk ��(��)����ΤȤ��� backing store ��Ȥ鷺��Χ���� 10000 ��(?)
+ ��������Τ�, (��)�����Ϥ���, �ޥ��󤬤��ʤ�Ť��ʤ�ޤ�.
+demo/lines0.tcl : wish �ѤΥ�����ץ�.
+demo/lines1.rb : `tk.rb' �ѤΥ�����ץ�.
+demo/lines2.rb : tcltk �饤�֥���ѤΥ�����ץ�.
+
+[����]
+
+����ѥ���/�¹Ԥˤ�, tcl/tk �� C �饤�֥�꤬ɬ�פǤ�.
+
+���Υ饤�֥���,
+
+ ruby-1.0-970701, ruby-1.0-970911, ruby-1.0-970919
+ FreeBSD 2.2.2-RELEASE
+ ����Ӥ��Υѥå����� jp-tcl-7.6.tgz, jp-tk-4.2.tgz
+
+�Ǻ���/ư���ǧ���ޤ���. ¾�δĶ��Ǥ�ư��뤫�ɤ����狼��ޤ���.
+
+TclTkLib.mainloop ��¹���� Control-C �������ʤ��Τ����ؤʤΤ�, ruby
+�Υ������򻲹ͤ�, #include "sig.h" ���� trap_immediate �����Ƥ���
+����, ruby �� README.EXT �ˤ�񤤤Ƥʤ��Τ�, ����ʤ��Ȥ򤷤��ɤ��Τ�
+�ɤ����狼��ޤ���.
+
+-d ���ץ����ǥǥХå������ɽ�������뤿���, ruby �Υ������򻲹ͤ�,
+debug �Ȥ�������ѿ��򻲾Ȥ��Ƥ��ޤ���, ruby �� README.EXT �ˤ�񤤤�
+�ʤ��Τ�, ����ʤ��Ȥ򤷤��ɤ��Τ��ɤ����狼��ޤ���.
+
+extconf.rb �Ͻ񤭤ޤ�����, (���������ʰ�̣��)������ɤ��Τ��ɤ�ʬ����
+�ޤ���.
+
+[��ħ]
+
+ruby ���� tcl/tk �饤�֥������ѤǤ��ޤ�.
+
+tcl/tk ���󥿥ץ꥿�Υ�����ץȤ�, ����Ū�� tcltk �饤�֥���Ѥ� ruby
+������ץȤ��Ѵ��Ǥ��ޤ�.
+
+(`tk.rb' �Ȥΰ㤤)
+
+1. tcl/tk ���󥿥ץ꥿�Υ�����ץȤ�, �ɤΤ褦��, tcltk �饤�֥���Ѥ�
+ ruby ������ץȤ��Ѵ�����뤫������Ǥ����, �ޥ˥奢���ब̵������
+ ���� `tk.rb' �Ȥϰۤʤ�
+
+ tcl/tk �Υޥ˥奢��䥪��饤��ɥ�����Ȥ��Ѥ���
+
+ ��Ψ�ɤ��ץ�����ߥ󥰤�Ԥ����Ȥ��Ǥ��ޤ�.
+ ������ˡ���狼��ʤ�, ���ޥ�ɤ�Ϳ����ѥ�᡼�����狼��ʤ�...
+ - Canvas.new { ... } ��, �ʤ����ƥ졼���֥��å���񤱤��??
+ - Canvas �� bbox �Ͽ��ͤΥꥹ�Ȥ��֤��Τ�, xview ��ʸ������֤���??
+ ��, ��������, �饤�֥��Υ��������ɤ�������ɬ�פϤ���ޤ���.
+
+2. �ġ��ε�ǽ(���ץ����)����̽����ˤ�ꥵ�ݡ��Ȥ��Ƥ���, ���Τ��᥵
+ �ݡ��Ȥ��Ƥ��ʤ���ǽ�ϻȤ����Ȥ��Ǥ��ʤ�(�����ϻȤ��ʤ����Ȥ�ʤ���
+ �Ǥ���) `tk.rb' �Ȥϰۤʤ�, tcl/tk ���󥿥ץ꥿�Dz�ǽ�ʤ��Ȥ�
+
+ �ۤȤ��
+
+ ruby �����¹ԤǤ��ޤ�. ����, ruby ����¹ԤǤ��ʤ����Ȥ���ǧ����
+ �Ƥ���Τ�,
+
+ bind ���ޥ�ɤǥ�����ץȤ��ɲä��빽ʸ
+ ��bind tag sequence +script��
+ ^
+
+ �ΤߤǤ�.
+ - `. configure -width' �򤷤褦�Ȥ���, `Tk.root.height()' �Ƚ�
+ ���Τ�, `undefined method `height'' ���ܤ��Ƥ��ޤä�. tk.rb ��
+ �ɤ�Ǥߤ�, ������. �Ǥ��ʤ��Τ�...
+ �Ȥ������ȤϤ���ޤ���.
+
+3. wish �ץ�������ư���ץ��������̿��� wish �����Ѥ��� `tk.rb' �Ȥ�
+ �ۤʤ�, tcl/tk �� C �饤�֥����󥯤�
+
+ ����®�� (�Ȥ��äƤ�, �פä�����®���ʤ��Ǥ���)
+
+ ������Ԥ��ޤ�.
+
+4. `tk.rb' �ۤ�, ����ʥ��󥿡��ե������������Ƥ��ʤ�����, tcl/tk ��
+ �󥿥ץ꥿��������
+
+ �����鲿�ޤǼ�ʬ�ǵ���
+
+ ���ʤ���Фʤ�ޤ���(��������, tcl/tk �饤�֥��λ����̤�,
+ tcl/tk ���󥿥ץ꥿��ʣ���������뤳�Ȥ�Ǥ��ޤ���).
+ ���󥿡��ե�������(�����餯) ruby �λ��ۤ˱�ä���ΤǤϤ���ޤ���.
+ �ޤ�, ������ץȤε��Ҥ�
+
+ ��������
+
+ �Ǥ�. ������ץȤ�, �츫, �ɤߤŤ餤��ΤȤʤ�ޤ�. ��, �񤯿ͤˤȤ�
+ �Ƥ�, ����ۤ��Ѥ路����ΤǤϤʤ��Ȼפ��ޤ�.
+
+[���󥹥ȡ������ˡ]
+
+0. ruby �Υ������ե�����(ruby-1.0-�ʤ󤿤�.tgz)��Ÿ�����Ƥ����ޤ�.
+
+1. ruby-1.0-�ʤ󤿤�/ext �� ext/tcltklib �򥳥ԡ����ޤ�.
+ cp -r ext/tcltklib ???/ruby-1.0-�ʤ󤿤�/ext/
+
+2. ruby �Υ��󥹥ȡ���ˡ�˽��� make ���򤷤ޤ�.
+
+3. ruby �Υ饤�֥���־�� lib/* �򥳥ԡ����ޤ�.
+ cp lib/* /usr/local/lib/ruby/
+
+(eof)
diff --git a/ext/tcltklib/demo/lines0.tcl b/ext/tcltklib/demo/lines0.tcl
new file mode 100644
index 0000000000..8ed3c5e1c1
--- /dev/null
+++ b/ext/tcltklib/demo/lines0.tcl
@@ -0,0 +1,42 @@
+#! /usr/local/bin/wish
+
+proc drawlines {} {
+ puts [clock format [clock seconds]]
+
+ for {set j 0} {$j < 100} {incr j} {
+ puts -nonewline "*"
+ flush stdout
+ if {$j & 1} {
+ set c "blue"
+ } {
+ set c "red"
+ }
+ for {set i 0} {$i < 100} {incr i} {
+# .a create line $i 0 0 [expr 500 - $i] -fill $c
+ }
+ }
+
+ puts [clock format [clock seconds]]
+
+ for {set j 0} {$j < 100} {incr j} {
+ puts -nonewline "*"
+ flush stdout
+ if {$j & 1} {
+ set c "blue"
+ } {
+ set c "red"
+ }
+ for {set i 0} {$i < 100} {incr i} {
+ .a create line $i 0 0 [expr 500 - $i] -fill $c
+ }
+ }
+
+ puts [clock format [clock seconds]]
+# destroy .
+}
+
+canvas .a -height 500 -width 500
+button .b -text draw -command drawlines
+pack .a .b -side left
+
+# eof
diff --git a/ext/tcltklib/demo/lines1.rb b/ext/tcltklib/demo/lines1.rb
new file mode 100644
index 0000000000..e459589f50
--- /dev/null
+++ b/ext/tcltklib/demo/lines1.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
+# TkcLine.new($a, 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
+ TkcLine.new($a, 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/lines2.rb b/ext/tcltklib/demo/lines2.rb
new file mode 100644
index 0000000000..9f21ae6377
--- /dev/null
+++ b/ext/tcltklib/demo/lines2.rb
@@ -0,0 +1,50 @@
+#! /usr/local/bin/ruby
+
+require "tcltk"
+
+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.e("create line", 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.e("create line", i, 0, 0, 500 - i, "-fill", col)
+ end
+ end
+
+ print Time.now, "\n"
+# $ip.commands()["destroy"].e($root)
+end
+
+$ip = TclTkInterpreter.new()
+$root = $ip.rootwidget()
+$a = TclTkWidget.new($ip, $root, "canvas", "-height 500 -width 500")
+$c = TclTkCallback.new($ip, proc{drawlines()})
+$b = TclTkWidget.new($ip, $root, "button", "-text draw -command", $c)
+
+$ip.commands()["pack"].e($a, $b, "-side left")
+
+TclTk.mainloop
+
+# eof
diff --git a/ext/tcltklib/depend b/ext/tcltklib/depend
new file mode 100644
index 0000000000..71d9f20537
--- /dev/null
+++ b/ext/tcltklib/depend
@@ -0,0 +1 @@
+tcltklib.o: tcltklib.c $(hdrdir)/ruby.h $(hdrdir)/config.h $(hdrdir)/defines.h
diff --git a/ext/tcltklib/extconf.rb b/ext/tcltklib/extconf.rb
new file mode 100644
index 0000000000..26e7fe7b09
--- /dev/null
+++ b/ext/tcltklib/extconf.rb
@@ -0,0 +1,79 @@
+# extconf.rb for tcltklib
+
+have_library("socket", "socket")
+have_library("nsl", "gethostbyname")
+
+def search_file(var, include, *path)
+ pwd = Dir.getwd
+ begin
+ for i in path.reverse!
+ dir = Dir[i]
+ for path in dir
+ Dir.chdir path
+ files = Dir[include]
+ if files.size > 0
+ var << path
+ return files.pop
+ end
+ end
+ end
+ ensure
+ Dir.chdir pwd
+ end
+end
+
+$includes = []
+search_file($includes,
+ "tcl.h",
+ "/usr/include/tcl*",
+ "/usr/include",
+ "/usr/local/include/tcl*",
+ "/usr/local/include")
+search_file($includes,
+ "tk.h",
+ "/usr/include/tk*",
+ "/usr/include",
+ "/usr/local/include/tk*",
+ "/usr/local/include")
+search_file($includes,
+ "X11/Xlib.h",
+ "/usr/include",
+ "/usr/X11*/include",
+ "/usr/include",
+ "/usr/X11*/include")
+
+$CFLAGS = "-Wall " + $includes.collect{|path| "-I" + path}.join(" ")
+
+$libraries = []
+tcllibfile = search_file($libraries,
+ "libtcl{,7*,8*}.{a,so}",
+ "/usr/lib",
+ "/usr/local/lib")
+if tcllibfile
+ tcllibfile.sub!(/^lib/, '')
+ tcllibfile.sub!(/\.(a|so)$/, '')
+end
+tklibfile = search_file($libraries,
+ "libtk{,4*,8*}.{a,so}",
+ "/usr/lib",
+ "/usr/local/lib")
+if tklibfile
+ tklibfile.sub!(/^lib/, '')
+ tklibfile.sub!(/\.(a|so)$/, '')
+end
+search_file($libraries,
+ "libX11.{a,so}",
+ "/usr/lib",
+ "/usr/X11*/lib")
+
+$LDFLAGS = $libraries.collect{|path| "-L" + path}.join(" ")
+
+have_library("dl", "dlopen")
+if have_header("tcl.h") &&
+ have_header("tk.h") &&
+ have_library("X11", "XOpenDisplay") &&
+ have_library("m", "log") &&
+ have_library(tcllibfile, "Tcl_FindExecutable") &&
+ have_library(tklibfile, "Tk_Init")
+ create_makefile("tcltklib")
+end
diff --git a/ext/tcltklib/lib/tcltk.rb b/ext/tcltklib/lib/tcltk.rb
new file mode 100644
index 0000000000..81d01f930d
--- /dev/null
+++ b/ext/tcltklib/lib/tcltk.rb
@@ -0,0 +1,388 @@
+# tof
+
+#### tcltk �饤�֥��
+#### Sep. 5, 1997 Y. Shigehiro
+
+require "tcltklib"
+
+################
+
+# module TclTk: tcl/tk �Υ饤�֥�����Τ�ɬ�פˤʤ��Τ򽸤᤿���
+# (���, ̾�����֤������� module �ˤ���Ȥ�.)
+module TclTk
+
+ # ñ�ˤ����˽񤱤кǽ�� 1 �ټ¹Ԥ����Τ�??
+
+ # ����������դ�̾�����ݻ����Ƥ���Ϣ���������������.
+ @namecnt = {}
+
+ # ������Хå����ݻ����Ƥ���Ϣ���������������.
+ @callback = {}
+end
+
+# TclTk.mainloop(): TclTkLib.mainloop() ��Ƥ�.
+def TclTk.mainloop()
+ print("mainloop: start\n") if $DEBUG
+ TclTkLib.mainloop()
+ print("mainloop: end\n") if $DEBUG
+end
+
+# TclTk.deletecallbackkey(ca): ������Хå��� TclTk module ���������.
+# tcl/tk ���󥿥ץ꥿�ˤ����ƥ�����Хå������ä����櫓�ǤϤʤ�.
+# ����򤷤ʤ���, �Ǹ�� TclTkInterpreter �� GC �Ǥ��ʤ�.
+# (GC �������ʤ����, �̤�, ����򤷤ʤ��Ƥ��ɤ�.)
+# ca: ������Хå�(TclTkCallback)
+def TclTk.deletecallbackkey(ca)
+ print("deletecallbackkey: ", ca.to_s(), "\n") if $DEBUG
+ @callback.delete(ca.to_s)
+end
+
+# TclTk.dcb(ca, wid, W): ��������äƤ���ʣ���Υ�����Хå����Ф���
+# TclTk.deletecallbackkey() ��Ƥ�.
+# �ȥåץ�٥�� <Destroy> ���٥�ȤΥ�����Хå��Ȥ��ƸƤ֤���Τ��.
+# ca: ������Хå�(TclTkCallback) �� Array
+# wid: �ȥåץ�٥�Υ��������å�(TclTkWidget)
+# w: ������Хå��� %W ��Ϳ������, ������ɥ��˴ؤ���ѥ�᡼��(String)
+def TclTk.dcb(ca, wid, w)
+ if wid.to_s() == w
+ ca.each{|i|
+ TclTk.deletecallbackkey(i)
+ }
+ end
+end
+
+# TclTk._addcallback(ca): ������Хå�����Ͽ����.
+# ca: ������Хå�(TclTkCallback)
+def TclTk._addcallback(ca)
+ print("_addcallback: ", ca.to_s(), "\n") if $DEBUG
+ @callback[ca.to_s()] = ca
+end
+
+# TclTk._callcallback(key, arg): ��Ͽ����������Хå���ƤӽФ�.
+# key: ������Хå������򤹤륭�� (TclTkCallback �� to_s() ���֤���)
+# arg: tcl/tk ���󥿥ץ꥿����Υѥ�᡼��
+def TclTk._callcallback(key, arg)
+ print("_callcallback: ", @callback[key].inspect, "\n") if $DEBUG
+ @callback[key]._call(arg)
+ # ������Хå�������֤��ͤϤɤ����ΤƤ���.
+ # String ���֤��ʤ���, rb_eval_string() �����顼�ˤʤ�.
+ return ""
+end
+
+# TclTk._newname(prefix): ��դ�̾��(String)�����������֤�.
+# prefix: ̾������Ƭ��
+def TclTk._newname(prefix)
+ # ��������̾���Υ����󥿤� @namecnt �����äƤ���Τ�, Ĵ�٤�.
+ if [email protected]?(prefix)
+ # ���ƻȤ���Ƭ��ʤΤǽ��������.
+ @namecnt[prefix] = 1
+ else
+ # �Ȥä����ȤΤ�����Ƭ��ʤΤ�, ����̾���ˤ���.
+ @namecnt[prefix] += 1
+ end
+ return "#{prefix}#{@namecnt[prefix]}"
+end
+
+################
+
+# class TclTkInterpreter: tcl/tk �Υ��󥿥ץ꥿
+class TclTkInterpreter
+
+ # initialize(): �����.
+ def initialize()
+ # ���󥿥ץ꥿����������.
+ @ip = TclTkIp.new()
+
+ # ���󥿥ץ꥿�� ruby_fmt ���ޥ�ɤ��ɲä���.
+ # ruby_fmt ���ޥ�ɤȤ�, ����ΰ����� format ���ޥ�ɤǽ�������
+ # ruby ���ޥ�ɤ��Ϥ���ΤǤ���.
+ # (�ʤ�, ruby ���ޥ�ɤ�, ������ 1 �Ĥ����Ȥ�ʤ�.)
+ if $DEBUG
+ @ip._eval("proc ruby_fmt {fmt args} { puts \"ruby_fmt: $fmt $args\" ; ruby [format $fmt $args] }")
+ else
+ @ip._eval("proc ruby_fmt {fmt args} { ruby [format $fmt $args] }")
+ end
+
+ # @ip._get_eval_string(*args): tcl/tk ���󥿥ץ꥿��ɾ������
+ # ʸ����(String)�����������֤�.
+ # *args: tcl/tk ��ɾ�����륹����ץ�(���б����륪�֥���������)
+ def @ip._get_eval_string(*args)
+ argstr = ""
+ args.each{|arg|
+ argstr += " " if argstr != ""
+ # �⤷ to_eval() �᥽�åɤ�
+ if (arg.respond_to?(:to_eval))
+ # �������Ƥ���Ф����Ƥ�.
+ argstr += arg.to_eval()
+ else
+ # �������Ƥ��ʤ���� to_s() ��Ƥ�.
+ argstr += arg.to_s()
+ end
+ }
+ return argstr
+ end
+
+ # @ip._eval_args(*args): tcl/tk ���󥿥ץ꥿��ɾ����,
+ # ���η��(String)���֤�.
+ # *args: tcl/tk ��ɾ�����륹����ץ�(���б����륪�֥���������)
+ def @ip._eval_args(*args)
+ # ���󥿥ץ꥿��ɾ������ʸ��������.
+ argstr = _get_eval_string(*args)
+
+ # ���󥿥ץ꥿��ɾ������.
+ print("_eval: \"", argstr, "\"") if $DEBUG
+ res = _eval(argstr)
+ if $DEBUG
+ print(" -> \"", res, "\"\n")
+ elsif _return_value() != 0
+ print(res, "\n")
+ end
+ fail(%Q/can't eval "#{argstr}"/) if _return_value() != 0
+ return res
+ end
+
+ # tcl/tk �Υ��ޥ�ɤ��б����륪�֥������Ȥ�������, Ϣ�����������Ƥ���.
+ @commands = {}
+ # tcl/tk ���󥿥ץ꥿����Ͽ����Ƥ��뤹�٤ƤΥ��ޥ�ɤ��Ф���,
+ @ip._eval("info command").split(/ /).each{|comname|
+ if comname =~ /^[.]/
+ # ���ޥ�ɤ����������å�(�Υѥ�̾)�ξ���
+ # TclTkWidget �Υ��󥹥��󥹤��ä�Ϣ������������.
+ @commands[comname] = TclTkWidget.new(@ip, comname)
+ else
+ # �����Ǥʤ�����
+ # TclTkCommand �Υ��󥹥��󥹤��ä�Ϣ������������.
+ @commands[comname] = TclTkCommand.new(@ip, comname)
+ end
+ }
+ end
+
+ # commands(): tcl/tk �Υ��ޥ�ɤ��б����륪�֥������Ȥ� Hash ��
+ # ���줿��Τ��֤�.
+ def commands()
+ return @commands
+ end
+
+ # rootwidget(): �롼�ȥ��������å�(TclTkWidget)���֤�.
+ def rootwidget()
+ return @commands["."]
+ end
+
+ # _tcltkip(): @ip(TclTkIp) ���֤�.
+ def _tcltkip()
+ return @ip
+ end
+
+ # method_missing(id, *args): ̤����Υ᥽�åɤ� tcl/tk �Υ��ޥ�ɤȤߤʤ���
+ # �¹Ԥ�, ���η��(String)���֤�.
+ # id: �᥽�åɤΥ���ܥ�
+ # *args: ���ޥ�ɤΰ���
+ def method_missing(id, *args)
+ # �⤷, �᥽�åɤ� tcl/tk ���ޥ�ɤ�
+ if @commands.key?(id.id2name)
+ # �����, �¹Ԥ��Ʒ�̤��֤�.
+ return @commands[id.id2name].e(*args)
+ else
+ # ̵����Ф�Ȥ�Ȥν���.
+ super
+ end
+ end
+end
+
+# class TclTkObject: tcl/tk �Υ��֥�������
+# (���쥯�饹�Ȥ��ƻȤ�.
+# tcltk �饤�֥���Ȥ��ͤ� TclTkObject.new() ���뤳�ȤϤʤ��Ϥ�.)
+class TclTkObject
+
+ # initialize(ip, exp): �����.
+ # ip: ���󥿥ץ꥿(TclTkIp)
+ # exp: tcl/tk �Ǥ�ɽ����
+ def initialize(ip, exp)
+ fail("type is not TclTkIp") if !ip.kind_of?(TclTkIp)
+ @ip = ip
+ @exp = exp
+ end
+
+ # to_s(): tcl/tk �Ǥ�ɽ����(String)���֤�.
+ def to_s()
+ return @exp
+ end
+end
+
+# class TclTkCommand: tcl/tk �Υ��ޥ��
+# (tcltk �饤�֥���Ȥ��ͤ� TclTkCommand.new() ���뤳�ȤϤʤ��Ϥ�.
+# TclTkInterpreter:initialize() ���� new() �����.)
+class TclTkCommand < TclTkObject
+
+ # e(*args): ���ޥ�ɤ�¹Ԥ�, ���η��(String)���֤�.
+ # (e �� exec �ޤ��� eval �� e.)
+ # *args: ���ޥ�ɤΰ���
+ def e(*args)
+ return @ip._eval_args(to_s(), *args)
+ end
+end
+
+# class TclTkLibCommand: tcl/tk �Υ��ޥ��
+# (�饤�֥��ˤ��¸�����륳�ޥ�ɤ�, tcl/tk ���󥿥ץ꥿�˺ǽ餫��
+# ¸�ߤ��ʤ���Τ�, ���󥿥ץ꥿�� commands() �Ǥ������Ǥ��ʤ�.
+# ���Τ褦�ʤ�Τ��Ф�, ���ޥ�ɤ�̾������ TclTkCommand ���֥������Ȥ�
+# ��������.
+class TclTkLibCommand < TclTkCommand
+
+ # initialize(ip, name): �����
+ # ip: ���󥿥ץ꥿(TclTkInterpreter)
+ # name: ���ޥ��̾ (String)
+ def initialize(ip, name)
+ super(ip._tcltkip, name)
+ end
+end
+
+# class TclTkVariable: tcl/tk ���ѿ�
+class TclTkVariable < TclTkObject
+
+ # initialize(interp, dat): �����.
+ # interp: ���󥿥ץ꥿(TclTkInterpreter)
+ # dat: ���ꤹ����(String)
+ # nil �ʤ�, ���ꤷ�ʤ�.
+ def initialize(interp, dat)
+ # tcl/tk �Ǥ�ɽ����(�ѿ�̾)��ư��������.
+ exp = TclTk._newname("v_")
+ # TclTkObject ����������.
+ super(interp._tcltkip(), exp)
+ # set ���ޥ�ɤ�Ȥ��ΤǤȤäƤ���.
+ @set = interp.commands()["set"]
+ # �ͤ����ꤹ��.
+ set(dat) if dat
+ end
+
+ # tcl/tk �� set ��Ȥ���, �ͤ�����/���ȤϤǤ��뤬,
+ # ��������ǤϤʤ�ʤΤ�, ���, �᥽�åɤ򤫤֤�����Τ��Ѱդ��Ƥ���.
+
+ # set(data): tcl/tk ���ѿ��� set ���Ѥ����ͤ����ꤹ��.
+ # data: ���ꤹ����
+ def set(data)
+ @set.e(to_s(), data.to_s())
+ end
+
+ # get(): tcl/tk ���ѿ�����(String)�� set ���Ѥ����ɤߤ����֤�.
+ def get()
+ return @set.e(to_s())
+ end
+end
+
+# class TclTkWidget: tcl/tk �Υ��������å�
+class TclTkWidget < TclTkCommand
+
+ # initialize(*args): �����.
+ # *args: �ѥ�᡼��
+ def initialize(*args)
+ if args[0].kind_of?(TclTkIp)
+ # �ǽ�ΰ����� TclTkIp �ξ��:
+
+ # ���� tcl/tk ���������Ƥ��륦�������åȤ� TclTkWidget �ι�¤��
+ # ���֤���. (TclTkInterpreter:initialize() ����Ȥ���.)
+
+ # �ѥ�᡼������ 2 �Ǥʤ���Х��顼.
+ fail("illegal # of parameter") if args.size != 2
+
+ # ip: ���󥿥ץ꥿(TclTkIp)
+ # exp: tcl/tk �Ǥ�ɽ����
+ ip, exp = args
+
+ # TclTkObject ����������.
+ super(ip, exp)
+ elsif args[0].kind_of?(TclTkInterpreter)
+ # �ǽ�ΰ����� TclTkInterpreter �ξ��:
+
+ # �ƥ��������åȤ��鿷���ʥ��������Ȥ���������.
+
+ # interp: ���󥿥ץ꥿(TclTkInterpreter)
+ # parent: �ƥ��������å�
+ # command: ���������åȤ��������륳�ޥ��(label ��)
+ # *args: command ���Ϥ�����
+ interp, parent, command, *args = args
+
+ # ���������åȤ�̾������.
+ exp = parent.to_s()
+ exp += "." if exp !~ /[.]$/
+ exp += TclTk._newname("w_")
+ # TclTkObject ����������.
+ super(interp._tcltkip(), exp)
+ # ���������åȤ���������.
+ res = @ip._eval_args(command, exp, *args)
+# fail("can't create Widget") if res != exp
+ # tk_optionMenu �Ǥ�, �ܥ���̾�� exp �ǻ��ꤹ���
+ # res �˥�˥塼̾���֤��Τ� res != exp �Ȥʤ�.
+ else
+ fail("first parameter is not TclTkInterpreter")
+ end
+ end
+end
+
+# class TclTkCallback: tcl/tk �Υ�����Хå�
+class TclTkCallback < TclTkObject
+
+ # initialize(interp, pr, arg): �����.
+ # interp: ���󥿥ץ꥿(TclTkInterpreter)
+ # pr: ������Хå���³��(Proc)
+ # arg: pr �Υ��ƥ졼���ѿ����Ϥ�ʸ����
+ # tcl/tk �� bind ���ޥ�ɤǤϥѥ�᡼���������뤿��� % �ִ���
+ # �Ѥ��뤬, pr �������� % ��񤤤Ƥ⤦�ޤ������ʤ�.
+ # arg ��ʸ�����񤤤Ƥ�����, �����ִ���̤�, pr ��
+ # ���ƥ졼���ѿ����̤��Ƽ�����뤳�Ȥ��Ǥ���.
+ # scrollbar ���ޥ�ɤ� -command ���ץ����Τ褦��
+ # ������ꤷ�ʤ��Ƥ�ѥ�᡼�����դ����ޥ�ɤ��Ф��Ƥ�,
+ # arg ����ꤷ�ƤϤʤ�ʤ�.
+ def initialize(interp, pr, arg = nil)
+ # tcl/tk �Ǥ�ɽ����(�ѿ�̾)��ư��������.
+ exp = TclTk._newname("c_")
+ # TclTkObject ����������.
+ super(interp._tcltkip(), exp)
+ # �ѥ�᡼����ȤäƤ���.
+ @pr = pr
+ @arg = arg
+ # �⥸�塼�����Ͽ���Ƥ���.
+ TclTk._addcallback(self)
+ end
+
+ # to_eval(): @ip._eval_args ��ɾ������Ȥ���ɽ����(String)���֤�.
+ def to_eval()
+ if @arg
+ # %s �� ruby_fmt ������� bind �ˤ���ִ�����Ƥ��ޤ��Τ�
+ # %%s �Ȥ��Ƥ���. �������ä�, ����� bind ����.
+ s = %Q/{ruby_fmt {TclTk._callcallback("#{to_s()}", "%%s")} #{@arg}}/
+ else
+ s = %Q/{ruby_fmt {TclTk._callcallback("#{to_s()}", "%s")}}/
+ end
+
+ return s
+ end
+
+ # _call(arg): ������Хå���ƤӽФ�.
+ # arg: ������Хå����Ϥ����ѥ�᡼��
+ def _call(arg)
+ @pr.call(arg)
+ end
+end
+
+# class TclTkImage: tcl/tk �Υ��᡼��
+class TclTkImage < TclTkCommand
+
+ # initialize(interp, t, *args): �����.
+ # ���᡼���������� TclTkImage.new() �ǹԤ���,
+ # �˲��� image delete �ǹԤ�. (���ޤ��������ɻ�����̵��.)
+ # interp: ���󥿥ץ꥿(TclTkInterpreter)
+ # t: ���᡼���Υ����� (photo, bitmap, etc.)
+ # *args: ���ޥ�ɤΰ���
+ def initialize(interp, t, *args)
+ # tcl/tk �Ǥ�ɽ����(�ѿ�̾)��ư��������.
+ exp = TclTk._newname("i_")
+ # TclTkObject ����������.
+ super(interp._tcltkip(), exp)
+ # ���᡼������������.
+ res = @ip._eval_args("image create", t, exp, *args)
+ fail("can't create Image") if res != exp
+ end
+end
+
+# eof
diff --git a/ext/tcltklib/sample/batsu.gif b/ext/tcltklib/sample/batsu.gif
new file mode 100644
index 0000000000..880cc73e09
--- /dev/null
+++ b/ext/tcltklib/sample/batsu.gif
Binary files differ
diff --git a/ext/tcltklib/sample/maru.gif b/ext/tcltklib/sample/maru.gif
new file mode 100644
index 0000000000..2c0202892e
--- /dev/null
+++ b/ext/tcltklib/sample/maru.gif
Binary files differ
diff --git a/ext/tcltklib/sample/sample0.rb b/ext/tcltklib/sample/sample0.rb
new file mode 100644
index 0000000000..cd4c8069b4
--- /dev/null
+++ b/ext/tcltklib/sample/sample0.rb
@@ -0,0 +1,39 @@
+#! /usr/local/bin/ruby -vd
+
+# tcltklib �饤�֥��Υƥ���
+
+require "tcltklib"
+
+def test
+ # ���󥿥ץ꥿����������
+ ip1 = TclTkIp.new()
+
+ # ɾ�����Ƥߤ�
+ print ip1._return_value().inspect, "\n"
+ print ip1._eval("puts {abc}").inspect, "\n"
+
+ # �ܥ�����äƤߤ�
+ print ip1._return_value().inspect, "\n"
+ print ip1._eval("button .lab -text exit -command \"destroy .\"").inspect,
+ "\n"
+ print ip1._return_value().inspect, "\n"
+ print ip1._eval("pack .lab").inspect, "\n"
+ print ip1._return_value().inspect, "\n"
+
+ # ���󥿥ץ꥿���� ruby ���ޥ�ɤ�ɾ�����Ƥߤ�
+# print ip1._eval(%q/ruby {print "print by ruby\n"}/).inspect, "\n"
+ print ip1._eval(%q+puts [ruby {print "print by ruby\n"; "puts by tcl/tk"}]+).inspect, "\n"
+ print ip1._return_value().inspect, "\n"
+
+ # �⤦��ĥ��󥿥ץ꥿���������Ƥߤ�
+ ip2 = TclTkIp.new()
+ ip2._eval("button .lab -text test -command \"puts test ; destroy .\"")
+ ip2._eval("pack .lab")
+
+ TclTkLib.mainloop
+end
+
+test
+GC.start
+
+print "exit\n"
diff --git a/ext/tcltklib/sample/sample1.rb b/ext/tcltklib/sample/sample1.rb
new file mode 100644
index 0000000000..28ba7b547a
--- /dev/null
+++ b/ext/tcltklib/sample/sample1.rb
@@ -0,0 +1,634 @@
+#! /usr/local/bin/ruby -d
+#! /usr/local/bin/ruby
+# -d ���ץ������դ����, �ǥХå������ɽ������.
+
+# tcltk �饤�֥��Υ���ץ�
+
+# �ޤ�, �饤�֥��� require ����.
+require "tcltk"
+
+# �ʲ���, Test1 �Υ��󥹥��󥹤� initialize() ��,
+# tcl/tk �˴ؤ��������Ԥ���Ǥ���.
+# ɬ�����⤽�Τ褦�ˤ���ɬ�פ�̵��,
+# (�⤷, �������������) class �γ��� tcl/tk �˴ؤ��������ԤäƤ��ɤ�.
+
+class Test1
+ # �����(���󥿥ץ꥿���������ƥ��������åȤ���������).
+ def initialize()
+
+ #### �Ȥ����Τ��ޤ��ʤ�
+
+ # ���󥿥ץ꥿������.
+ ip = TclTkInterpreter.new()
+ # ���ޥ�ɤ��б����륪�֥������Ȥ� c �����ꤷ�Ƥ���.
+ c = ip.commands()
+ # ���Ѥ��륳�ޥ�ɤ��б����륪�֥������Ȥ��ѿ�������Ƥ���.
+ append, bind, button, destroy, incr, info, label, place, set, wm =
+ c.indexes(
+ "append", "bind", "button", "destroy", "incr", "info", "label", "place",
+ "set", "wm")
+
+ #### tcl/tk �Υ��ޥ�ɤ��б����륪�֥�������(TclTkCommand)�����
+
+ # �¹Ԥ������, e() �᥽�åɤ�Ȥ�.
+ # (�ʲ���, tcl/tk �ˤ����� info command r* ��¹�.)
+ print info.e("command", "r*"), "\n"
+ # ������, �ޤȤ᤿ʸ����ˤ��Ƥ�Ʊ��.
+ print info.e("command r*"), "\n"
+ # �ѿ����Ѥ��ʤ��Ȥ�¹ԤǤ��뤬, �����᤬����.
+ print c["info"].e("command", "r*"), "\n"
+ # ���󥿥ץ꥿�Υ᥽�åɤȤ��Ƥ�¹ԤǤ��뤬, ��Ψ������.
+ print ip.info("command", "r*"), "\n"
+
+ ####
+
+ # �ʲ�, �����������֥������Ȥ��ѿ����������Ƥ����ʤ���
+ # GC ���оݤˤʤäƤ��ޤ�.
+
+ #### tcl/tk ���ѿ����б����륪�֥�������(TclTkVariable)�����
+
+ # ������Ʊ�����ͤ����ꤹ��.
+ v1 = TclTkVariable.new(ip, "20")
+ # �ɤ߽Ф��� get �᥽�åɤ�Ȥ�.
+ print v1.get(), "\n"
+ # ����� set �᥽�åɤ�Ȥ�.
+ v1.set(40)
+ print v1.get(), "\n"
+ # set ���ޥ�ɤ�Ȥä��ɤ߽Ф�, ����ϲ�ǽ���������᤬����.
+ # e() �᥽�å����ΰ�����ľ�� TclTkObject ����ͤ�񤤤Ƥ��ɤ�.
+ set.e(v1, 30)
+ print set.e(v1), "\n"
+ # tcl/tk �Υ��ޥ�ɤ��ѿ������Ǥ���.
+ incr.e(v1)
+ print v1.get(), "\n"
+ append.e(v1, 10)
+ print v1.get(), "\n"
+
+ #### tcl/tk �Υ��������åȤ��б����륪�֥�������(TclTkWidget)�����
+
+ # �롼�ȥ��������åȤ���Ф�.
+ root = ip.rootwidget()
+ # ���������åȤ����.
+ root.e("configure -height 300 -width 300")
+ # �����ȥ���դ���Ȥ��� wm ��Ȥ�.
+ wm.e("title", root, $0)
+ # �ƥ��������åȤȥ��ޥ�ɤ���ꤷ��, ���������åȤ���.
+ l1 = TclTkWidget.new(ip, root, label, "-text {type `x' to print}")
+ # place �����ɽ�������.
+ place.e(l1, "-x 0 -rely 0.0 -relwidth 1 -relheight 0.1")
+ # ���ޥ��̾��ʸ����ǻ��ꤷ�Ƥ��ɤ���, �����᤬����.
+ # (���ޥ��̾����Ω���������Ǥʤ���Фʤ�ʤ�.)
+ l2 = TclTkWidget.new(ip, root, "label")
+ # ���������åȤ����.
+ l2.e("configure -text {type `q' to exit}")
+ place.e(l2, "-x 0 -rely 0.1 -relwidth 1 -relheight 0.1")
+
+ #### tcl/tk �Υ�����Хå����б����륪�֥�������(TclTkCallback)�����
+
+ # ������Хå�����������.
+ c1 = TclTkCallback.new(ip, proc{sample(ip, root)})
+ # ������Хå�����ĥ��������åȤ���������.
+ b1 = TclTkWidget.new(ip, root, button, "-text sample -command", c1)
+ place.e(b1, "-x 0 -rely 0.2 -relwidth 1 -relheight 0.1")
+ # ���٥�ȥ롼�פ�ȴ����ˤ� destroy.e(root) ����.
+ c2 = TclTkCallback.new(ip, proc{destroy.e(root)})
+ b2 = TclTkWidget.new(ip, root, button, "-text exit -command", c2)
+ place.e(b2, "-x 0 -rely 0.3 -relwidth 1 -relheight 0.1")
+
+ #### ���٥�ȤΥХ����
+ # script ���ɲ� (bind tag sequence +script) �Ϻ��ΤȤ����Ǥ��ʤ�.
+ # (���ƥ졼���ѿ������꤬���ޤ������ʤ�.)
+
+ # ����Ū�ˤϥ��������åȤ��Ф��륳����Хå���Ʊ��.
+ c3 = TclTkCallback.new(ip, proc{print("q pressed\n"); destroy.e(root)})
+ bind.e(root, "q", c3)
+ # bind ���ޥ�ɤ� % �ִ��ˤ��ѥ�᡼���������ꤿ���Ȥ���,
+ # proc{} �θ����ʸ����ǻ��ꤹ���,
+ # �ִ���̤򥤥ƥ졼���ѿ����̤��Ƽ�����뤳�Ȥ��Ǥ���.
+ # ������ proc{} �θ����ʸ�����,
+ # bind ���ޥ�ɤ�Ϳ���륳����Хå��ʳ��ǻ��ꤷ�ƤϤ����ʤ�.
+ c4 = TclTkCallback.new(ip, proc{|i| print("#{i} pressed\n")}, "%A")
+ bind.e(root, "x", c4)
+ # TclTkCallback �� GC ���оݤˤ��������,
+ # dcb() (�ޤ��� deletecallbackkeys()) ����ɬ�פ�����.
+ cb = [c1, c2, c3, c4]
+ c5 = TclTkCallback.new(ip, proc{|w| TclTk.dcb(cb, root, w)}, "%W")
+ bind.e(root, "<Destroy>", c5)
+ cb.push(c5)
+
+ #### tcl/tk �Υ��᡼�����б����륪�֥�������(TclTkImage)�����
+
+ # �ǡ�������ꤷ����������.
+ i1 = TclTkImage.new(ip, "photo", "-file maru.gif")
+ # ��٥��ĥ���դ��Ƥߤ�.
+ l3 = TclTkWidget.new(ip, root, label, "-relief raised -image", i1)
+ place.e(l3, "-x 0 -rely 0.4 -relwidth 0.2 -relheight 0.2")
+ # ���Υ��᡼�����������Ƹ������.
+ i2 = TclTkImage.new(ip, "photo")
+ # ���᡼��������.
+ i2.e("copy", i1)
+ i2.e("configure -gamma 0.5")
+ l4 = TclTkWidget.new(ip, root, label, "-relief raised -image", i2)
+ place.e(l4, "-relx 0.2 -rely 0.4 -relwidth 0.2 -relheight 0.2")
+
+ ####
+ end
+
+ # ����ץ�Τ���Υ��������åȤ���������.
+ def sample(ip, parent)
+ bind, button, destroy, grid, toplevel, wm = ip.commands().indexes(
+ "bind", "button", "destroy", "grid", "toplevel", "wm")
+
+ ## toplevel
+
+ # ������������ɥ��򳫤��ˤ�, toplevel ��Ȥ�.
+ t1 = TclTkWidget.new(ip, parent, toplevel)
+ # �����ȥ���դ��Ƥ���
+ wm.e("title", t1, "sample")
+
+ # ���������åȤ��˲����줿�Ȥ�, ������Хå��� GC ���оݤˤʤ�褦�ˤ���.
+ cb = []
+ cb.push(c = TclTkCallback.new(ip, proc{|w| TclTk.dcb(cb, t1, w)}, "%W"))
+ bind.e(t1, "<Destroy>", c)
+
+ # �ܥ��������.
+ wid = []
+ # toplevel ���������åȤ��˲�����ˤ� destroy ����.
+ cb.push(c = TclTkCallback.new(ip, proc{destroy.e(t1)}))
+ wid.push(TclTkWidget.new(ip, t1, button, "-text close -command", c))
+ cb.push(c = TclTkCallback.new(ip, proc{test_label(ip, t1)}))
+ wid.push(TclTkWidget.new(ip, t1, button, "-text label -command", c))
+ cb.push(c = TclTkCallback.new(ip, proc{test_button(ip, t1)}))
+ wid.push(TclTkWidget.new(ip, t1, button, "-text button -command", c))
+ cb.push(c = TclTkCallback.new(ip, proc{test_checkbutton(ip, t1)}))
+ wid.push(TclTkWidget.new(ip, t1, button, "-text checkbutton -command", c))
+ cb.push(c = TclTkCallback.new(ip, proc{test_radiobutton(ip, t1)}))
+ wid.push(TclTkWidget.new(ip, t1, button, "-text radiobutton -command", c))
+ cb.push(c = TclTkCallback.new(ip, proc{test_scale(ip, t1)}))
+ wid.push(TclTkWidget.new(ip, t1, button, "-text scale -command", c))
+ cb.push(c = TclTkCallback.new(ip, proc{test_entry(ip, t1)}))
+ wid.push(TclTkWidget.new(ip, t1, button, "-text entry -command", c))
+ cb.push(c = TclTkCallback.new(ip, proc{test_text(ip, t1)}))
+ wid.push(TclTkWidget.new(ip, t1, button, "-text text -command", c))
+ cb.push(c = TclTkCallback.new(ip, proc{test_raise(ip, t1)}))
+ wid.push(TclTkWidget.new(ip, t1, button, "-text raise/lower -command", c))
+ cb.push(c = TclTkCallback.new(ip, proc{test_modal(ip, t1)}))
+ wid.push(TclTkWidget.new(ip, t1, button, "-text message/modal -command",
+ c))
+ cb.push(c = TclTkCallback.new(ip, proc{test_menu(ip, t1)}))
+ wid.push(TclTkWidget.new(ip, t1, button, "-text menu -command", c))
+ cb.push(c = TclTkCallback.new(ip, proc{test_listbox(ip, t1)}))
+ wid.push(TclTkWidget.new(ip, t1, button, "-text listbox/scrollbar",
+ "-command", c))
+ cb.push(c = TclTkCallback.new(ip, proc{test_canvas(ip, t1)}))
+ wid.push(TclTkWidget.new(ip, t1, button, "-text canvas -command", c))
+
+ # grid ��ɽ������.
+ ro = co = 0
+ wid.each{|w|
+ grid.e(w, "-row", ro, "-column", co, "-sticky news")
+ ro += 1
+ if ro == 7
+ ro = 0
+ co += 1
+ end
+ }
+ end
+
+ # inittoplevel(ip, parent, title)
+ # �ʲ��ν�����ޤȤ�ƹԤ�.
+ # 1. toplevel ���������åȤ��������.
+ # 2. ������Хå�����Ͽ����������Ѱդ�, toplevel ���������åȤ�
+ # <Destroy> ���٥�Ȥ˥�����Хå����������³������Ͽ����.
+ # 3. ���������ܥ������.
+ # �������� toplevel ���������å�, ���������ܥ���, ������Хå���Ͽ���ѿ�
+ # ���֤�.
+ # ip: ���󥿥ץ꥿
+ # parent: �ƥ��������å�
+ # title: toplevel ���������åȤΥ�����ɥ��Υ����ȥ�
+ def inittoplevel(ip, parent, title)
+ bind, button, destroy, toplevel, wm = ip.commands().indexes(
+ "bind", "button", "destroy", "toplevel", "wm")
+
+ # ������������ɥ��򳫤��ˤ�, toplevel ��Ȥ�.
+ t1 = TclTkWidget.new(ip, parent, toplevel)
+ # �����ȥ���դ��Ƥ���
+ wm.e("title", t1, title)
+
+ # ���������åȤ��˲����줿�Ȥ�, ������Хå��� GC ���оݤˤʤ�褦�ˤ���.
+ cb = []
+ cb.push(c = TclTkCallback.new(ip, proc{|w| TclTk.dcb(cb, t1, w)}, "%W"))
+ bind.e(t1, "<Destroy>", c)
+ # close �ܥ�����äƤ���.
+ # toplevel ���������åȤ��˲�����ˤ� destroy ����.
+ cb.push(c = TclTkCallback.new(ip, proc{destroy.e(t1)}))
+ b1 = TclTkWidget.new(ip, t1, button, "-text close -command", c)
+
+ return t1, b1, cb
+ end
+
+ # label �Υ���ץ�.
+ def test_label(ip, parent)
+ button, global, label, pack = ip.commands().indexes(
+ "button", "global", "label", "pack")
+ t1, b1, cb = inittoplevel(ip, parent, "label")
+
+ ## label
+
+ # ���������ʷ��Υ�٥�.
+ l1 = TclTkWidget.new(ip, t1, label, "-text {default(flat)}")
+ l2 = TclTkWidget.new(ip, t1, label, "-text raised -relief raised")
+ l3 = TclTkWidget.new(ip, t1, label, "-text sunken -relief sunken")
+ l4 = TclTkWidget.new(ip, t1, label, "-text groove -relief groove")
+ l5 = TclTkWidget.new(ip, t1, label, "-text ridge -relief ridge")
+ l6 = TclTkWidget.new(ip, t1, label, "-bitmap error")
+ l7 = TclTkWidget.new(ip, t1, label, "-bitmap questhead")
+
+ # pack ���Ƥ�ɽ�������.
+ pack.e(b1, l1, l2, l3, l4, l5, l6, l7, "-pady 3")
+
+ ## -textvariable
+
+ # tcltk �饤�֥��μ����Ǥ�, ������Хå��� tcl/tk ��``��³��''���̤���
+ # �ƤФ��. �������ä�, ������Хå������(���)�ѿ��˥�����������Ȥ���,
+ # global ����ɬ�פ�����.
+ # global ���������ѿ����ͤ����ꤷ�Ƥ��ޤ��ȥ��顼�ˤʤ�Τ�,
+ # tcl/tk �ˤ�����ɽ����������������, �ºݤ��ͤ����ꤷ�ʤ��褦��,
+ # 2 ���ܤΰ����ˤ� nil ��Ϳ����.
+ v1 = TclTkVariable.new(ip, nil)
+ global.e(v1)
+ v1.set(100)
+ # -textvariable ���ѿ������ꤹ��.
+ l6 = TclTkWidget.new(ip, t1, label, "-textvariable", v1)
+ # ������Хå����椫���ѿ�������.
+ cb.push(c = TclTkCallback.new(ip, proc{
+ global.e(v1); v1.set(v1.get().to_i + 10)}))
+ b2 = TclTkWidget.new(ip, t1, button, "-text +10 -command", c)
+ cb.push(c = TclTkCallback.new(ip, proc{
+ global.e(v1); v1.set(v1.get().to_i - 10)}))
+ b3 = TclTkWidget.new(ip, t1, button, "-text -10 -command", c)
+ pack.e(l6, b2, b3)
+ end
+
+ # button �Υ���ץ�.
+ def test_button(ip, parent)
+ button, pack = ip.commands().indexes("button", "pack")
+ t1, b1, cb = inittoplevel(ip, parent, "button")
+
+ ## button
+
+ # ������Хå���ǻ��Ȥ����ѿ������������Ƥ����ʤ���Фʤ�ʤ�.
+ b3 = b4 = nil
+ cb.push(c = TclTkCallback.new(ip, proc{b3.e("flash"); b4.e("flash")}))
+ b2 = TclTkWidget.new(ip, t1, button, "-text flash -command", c)
+ cb.push(c = TclTkCallback.new(ip, proc{b2.e("configure -state normal")}))
+ b3 = TclTkWidget.new(ip, t1, button, "-text normal -command", c)
+ cb.push(c = TclTkCallback.new(ip, proc{b2.e("configure -state disabled")}))
+ b4 = TclTkWidget.new(ip, t1, button, "-text disable -command", c)
+ pack.e(b1, b2, b3, b4)
+ end
+
+ # checkbutton �Υ���ץ�.
+ def test_checkbutton(ip, parent)
+ checkbutton, global, pack = ip.commands().indexes(
+ "checkbutton", "global", "pack")
+ t1, b1, cb = inittoplevel(ip, parent, "checkbutton")
+
+ ## checkbutton
+
+ v1 = TclTkVariable.new(ip, nil)
+ global.e(v1)
+ # -variable ���ѿ������ꤹ��.
+ ch1 = TclTkWidget.new(ip, t1, checkbutton, "-onvalue on -offvalue off",
+ "-textvariable", v1, "-variable", v1)
+ pack.e(b1, ch1)
+ end
+
+ # radiobutton �Υ���ץ�.
+ def test_radiobutton(ip, parent)
+ global, label, pack, radiobutton = ip.commands().indexes(
+ "global", "label", "pack", "radiobutton")
+ t1, b1, cb = inittoplevel(ip, parent, "radiobutton")
+
+ ## radiobutton
+
+ v1 = TclTkVariable.new(ip, nil)
+ global.e(v1)
+ # �̥륹�ȥ�󥰤� "{}" �ǻ��ꤹ��.
+ v1.set("{}")
+ l1 = TclTkWidget.new(ip, t1, label, "-textvariable", v1)
+ # -variable ��Ʊ���ѿ�����ꤹ���Ʊ�����롼�פˤʤ�.
+ ra1 = TclTkWidget.new(ip, t1, radiobutton,
+ "-text radio1 -value r1 -variable", v1)
+ ra2 = TclTkWidget.new(ip, t1, radiobutton,
+ "-text radio2 -value r2 -variable", v1)
+ cb.push(c = TclTkCallback.new(ip, proc{global.e(v1); v1.set("{}")}))
+ ra3 = TclTkWidget.new(ip, t1, radiobutton,
+ "-text clear -value r3 -variable", v1, "-command", c)
+ pack.e(b1, l1, ra1, ra2, ra3)
+ end
+
+ # scale �Υ���ץ�.
+ def test_scale(ip, parent)
+ global, pack, scale = ip.commands().indexes(
+ "global", "pack", "scale")
+ t1, b1, cb = inittoplevel(ip, parent, "scale")
+
+ ## scale
+
+ v1 = TclTkVariable.new(ip, nil)
+ global.e(v1)
+ v1.set(219)
+ # ������Хå���ǻ��Ȥ����ѿ������������Ƥ����ʤ���Фʤ�ʤ�.
+ sca1 = nil
+ cb.push(c = TclTkCallback.new(ip, proc{global.e(v1); v = v1.get();
+ sca1.e("configure -background", format("#%02x%02x%02x", v, v, v))}))
+ sca1 = TclTkWidget.new(ip, t1, scale,
+ "-label scale -orient h -from 0 -to 255 -variable", v1, "-command", c)
+ pack.e(b1, sca1)
+ end
+
+ # entry �Υ���ץ�.
+ def test_entry(ip, parent)
+ button, entry, global, pack = ip.commands().indexes(
+ "button", "entry", "global", "pack")
+ t1, b1, cb = inittoplevel(ip, parent, "entry")
+
+ ## entry
+
+ v1 = TclTkVariable.new(ip, nil)
+ global.e(v1)
+ # �̥륹�ȥ�󥰤� "{}" �ǻ��ꤹ��.
+ v1.set("{}")
+ en1 = TclTkWidget.new(ip, t1, entry, "-textvariable", v1)
+ cb.push(c = TclTkCallback.new(ip, proc{
+ global.e(v1); print(v1.get(), "\n"); v1.set("{}")}))
+ b2 = TclTkWidget.new(ip, t1, button, "-text print -command", c)
+ pack.e(b1, en1, b2)
+ end
+
+ # text �Υ���ץ�.
+ def test_text(ip, parent)
+ button, pack, text = ip.commands().indexes(
+ "button", "pack", "text")
+ t1, b1, cb = inittoplevel(ip, parent, "text")
+
+ ## text
+
+ te1 = TclTkWidget.new(ip, t1, text)
+ cb.push(c = TclTkCallback.new(ip, proc{
+ # 1 ���ܤ� 0 ʸ���ܤ���Ǹ�ޤǤ�ɽ����, �������.
+ print(te1.e("get 1.0 end")); te1.e("delete 1.0 end")}))
+ b2 = TclTkWidget.new(ip, t1, button, "-text print -command", c)
+ pack.e(b1, te1, b2)
+ end
+
+ # raise/lower �Υ���ץ�.
+ def test_raise(ip, parent)
+ button, frame, lower, pack, raise = ip.commands().indexes(
+ "button", "frame", "lower", "pack", "raise")
+ t1, b1, cb = inittoplevel(ip, parent, "raise/lower")
+
+ ## raise/lower
+
+ # button �򱣤��ƥ��ȤΤ����, frame ��Ȥ�.
+ f1 = TclTkWidget.new(ip, t1, frame)
+ # ������Хå���ǻ��Ȥ����ѿ������������Ƥ����ʤ���Фʤ�ʤ�.
+ b2 = nil
+ cb.push(c = TclTkCallback.new(ip, proc{raise.e(f1, b2)}))
+ b2 = TclTkWidget.new(ip, t1, button, "-text raise -command", c)
+ cb.push(c = TclTkCallback.new(ip, proc{lower.e(f1, b2)}))
+ b3 = TclTkWidget.new(ip, t1, button, "-text lower -command", c)
+ lower.e(f1, b3)
+
+ pack.e(b2, b3, "-in", f1)
+ pack.e(b1, f1)
+ end
+
+ # modal �ʥ��������åȤΥ���ץ�.
+ def test_modal(ip, parent)
+ button, frame, message, pack, tk_chooseColor, tk_getOpenFile,
+ tk_messageBox = ip.commands().indexes(
+ "button", "frame", "message", "pack", "tk_chooseColor",
+ "tk_getOpenFile", "tk_messageBox")
+ # �ǽ�� load ����Ƥ��ʤ��饤�֥��� ip.commands() ��¸�ߤ��ʤ��Τ�,
+ # TclTkLibCommand ����������ɬ�פ�����.
+ tk_dialog = TclTkLibCommand.new(ip, "tk_dialog")
+ t1, b1, cb = inittoplevel(ip, parent, "message/modal")
+
+ ## message
+
+ mes = "����� message ���������åȤΥƥ��ȤǤ�."
+ mes += "�ʲ��� modal �ʥ��������åȤΥƥ��ȤǤ�."
+ me1 = TclTkWidget.new(ip, t1, message, "-text {#{mes}}")
+
+ ## modal
+
+ # tk_messageBox
+ cb.push(c = TclTkCallback.new(ip, proc{
+ print tk_messageBox.e("-type yesnocancel -message messageBox",
+ "-icon error -default cancel -title messageBox"), "\n"}))
+ b2 = TclTkWidget.new(ip, t1, button, "-text messageBox -command", c)
+ # tk_dialog
+ cb.push(c = TclTkCallback.new(ip, proc{
+ # ���������å�̾���������뤿��˥��ߡ��� frame ������.
+ print tk_dialog.e(TclTkWidget.new(ip, t1, frame),
+ "dialog dialog error 2 yes no cancel"), "\n"}))
+ b3 = TclTkWidget.new(ip, t1, button, "-text dialog -command", c)
+ # tk_chooseColor
+ cb.push(c = TclTkCallback.new(ip, proc{
+ print tk_chooseColor.e("-title chooseColor"), "\n"}))
+ b4 = TclTkWidget.new(ip, t1, button, "-text chooseColor -command", c)
+ # tk_getOpenFile
+ cb.push(c = TclTkCallback.new(ip, proc{
+ print tk_getOpenFile.e("-defaultextension .rb",
+ "-filetypes {{{Ruby Script} {.rb}} {{All Files} {*}}}",
+ "-title getOpenFile"), "\n"}))
+ b5 = TclTkWidget.new(ip, t1, button, "-text getOpenFile -command", c)
+
+ pack.e(b1, me1, b2, b3, b4, b5)
+ end
+
+ # menu �Υ���ץ�.
+ def test_menu(ip, parent)
+ global, menu, menubutton, pack = ip.commands().indexes(
+ "global", "menu", "menubutton", "pack")
+ tk_optionMenu = TclTkLibCommand.new(ip, "tk_optionMenu")
+ t1, b1, cb = inittoplevel(ip, parent, "menu")
+
+ ## menu
+
+ # menubutton ����������.
+ mb1 = TclTkWidget.new(ip, t1, menubutton, "-text menu")
+ # menu ����������.
+ me1 = TclTkWidget.new(ip, mb1, menu)
+ # mb1 ���� me1 ����ư�����褦�ˤ���.
+ mb1.e("configure -menu", me1)
+
+ # cascade �ǵ�ư����� menu ����������.
+ me11 = TclTkWidget.new(ip, me1, menu)
+ # radiobutton �Υ���ץ�.
+ v1 = TclTkVariable.new(ip, nil); global.e(v1); v1.set("r1")
+ me11.e("add radiobutton -label radio1 -value r1 -variable", v1)
+ me11.e("add radiobutton -label radio2 -value r2 -variable", v1)
+ me11.e("add radiobutton -label radio3 -value r3 -variable", v1)
+ # cascade �ˤ�� mb11 ����ư�����褦�ˤ���.
+ me1.e("add cascade -label cascade -menu", me11)
+
+ # checkbutton �Υ���ץ�.
+ v2 = TclTkVariable.new(ip, nil); global.e(v2); v2.set("none")
+ me1.e("add checkbutton -label check -variable", v2)
+ # separator �Υ���ץ�.
+ me1.e("add separator")
+ # command �Υ���ץ�.
+ v3 = nil
+ cb.push(c = TclTkCallback.new(ip, proc{
+ global.e(v1, v2, v3); print "v1: ", v1.get(), ", v2: ", v2.get(),
+ ", v3: ", v3.get(), "\n"}))
+ me1.e("add command -label print -command", c)
+
+ ## tk_optionMenu
+
+ v3 = TclTkVariable.new(ip, nil); global.e(v3); v3.set("opt2")
+ om1 = TclTkWidget.new(ip, t1, tk_optionMenu, v3, "opt1 opt2 opt3 opt4")
+
+ pack.e(b1, mb1, om1, "-side left")
+ end
+
+ # listbox �Υ���ץ�.
+ def test_listbox(ip, parent)
+ clipboard, frame, grid, listbox, lower, menu, menubutton, pack, scrollbar,
+ selection = ip.commands().indexes(
+ "clipboard", "frame", "grid", "listbox", "lower", "menu", "menubutton",
+ "pack", "scrollbar", "selection")
+ t1, b1, cb = inittoplevel(ip, parent, "listbox")
+
+ ## listbox/scrollbar
+
+ f1 = TclTkWidget.new(ip, t1, frame)
+ # ������Хå���ǻ��Ȥ����ѿ������������Ƥ����ʤ���Фʤ�ʤ�.
+ li1 = sc1 = sc2 = nil
+ # �¹Ի���, ����˥ѥ�᡼�����Ĥ�������Хå���,
+ # ���ƥ졼���ѿ��Ǥ��Υѥ�᡼���������뤳�Ȥ��Ǥ���.
+ # (ʣ���Υѥ�᡼���ϤҤȤĤ�ʸ����ˤޤȤ����.)
+ cb.push(c1 = TclTkCallback.new(ip, proc{|i| li1.e("xview", i)}))
+ cb.push(c2 = TclTkCallback.new(ip, proc{|i| li1.e("yview", i)}))
+ cb.push(c3 = TclTkCallback.new(ip, proc{|i| sc1.e("set", i)}))
+ cb.push(c4 = TclTkCallback.new(ip, proc{|i| sc2.e("set", i)}))
+ # listbox
+ li1 = TclTkWidget.new(ip, f1, listbox,
+ "-xscrollcommand", c3, "-yscrollcommand", c4,
+ "-selectmode extended -exportselection true")
+ for i in 1..20
+ li1.e("insert end {line #{i} line #{i} line #{i} line #{i} line #{i}}")
+ end
+ # scrollbar
+ sc1 = TclTkWidget.new(ip, f1, scrollbar, "-orient horizontal -command", c1)
+ sc2 = TclTkWidget.new(ip, f1, scrollbar, "-orient vertical -command", c2)
+
+ ## selection/clipboard
+
+ mb1 = TclTkWidget.new(ip, t1, menubutton, "-text edit")
+ me1 = TclTkWidget.new(ip, mb1, menu)
+ mb1.e("configure -menu", me1)
+ cb.push(c = TclTkCallback.new(ip, proc{
+ # clipboard �򥯥ꥢ.
+ clipboard.e("clear")
+ # selection ����ʸ������ɤ߹��� clipboard ���ɲä���.
+ clipboard.e("append {#{selection.e(\"get\")}}")}))
+ me1.e("add command -label {selection -> clipboard} -command",c)
+ cb.push(c = TclTkCallback.new(ip, proc{
+ # li1 �򥯥ꥢ.
+ li1.e("delete 0 end")
+ # clipboard ����ʸ�������Ф�, 1 �Ԥ���
+ selection.e("get -selection CLIPBOARD").split(/\n/).each{|line|
+ # li1 ����������.
+ li1.e("insert end {#{line}}")}}))
+ me1.e("add command -label {clipboard -> listbox} -command",c)
+
+ grid.e(li1, "-row 0 -column 0 -sticky news")
+ grid.e(sc1, "-row 1 -column 0 -sticky ew")
+ grid.e(sc2, "-row 0 -column 1 -sticky ns")
+ grid.e("rowconfigure", f1, "0 -weight 100")
+ grid.e("columnconfigure", f1, "0 -weight 100")
+ f2 = TclTkWidget.new(ip, t1, frame)
+ lower.e(f2, b1)
+ pack.e(b1, mb1, "-in", f2, "-side left")
+ pack.e(f2, f1)
+ end
+
+ # canvas �Υ���ץ�.
+ def test_canvas(ip, parent)
+ canvas, lower, pack = ip.commands().indexes("canvas", "lower", "pack")
+ t1, b1, cb = inittoplevel(ip, parent, "canvas")
+
+ ## canvas
+
+ ca1 = TclTkWidget.new(ip, t1, canvas, "-width 400 -height 300")
+ lower.e(ca1, b1)
+ # rectangle ����.
+ idr = ca1.e("create rectangle 10 10 20 20")
+ # oval ����.
+ ca1.e("create oval 60 10 100 50")
+ # polygon ����.
+ ca1.e("create polygon 110 10 110 30 140 10")
+ # line ����.
+ ca1.e("create line 150 10 150 30 190 10")
+ # arc ����.
+ ca1.e("create arc 200 10 250 50 -start 0 -extent 90 -style pieslice")
+ # i1 ��������, �ɤ������˲����ʤ���Фʤ�ʤ���, ���ݤʤΤ����äƤ���.
+ i1 = TclTkImage.new(ip, "photo", "-file maru.gif")
+ # image ����.
+ ca1.e("create image 100 100 -image", i1)
+ # bitmap ����.
+ ca1.e("create bitmap 260 50 -bitmap questhead")
+ # text ����.
+ ca1.e("create text 320 50 -text {drag rectangle}")
+ # window ����(���������ܥ���).
+ ca1.e("create window 200 200 -window", b1)
+
+ # bind �ˤ�� rectangle �� drag �Ǥ���褦�ˤ���.
+ cb.push(c = TclTkCallback.new(ip, proc{|i|
+ # i �� x �� y ��������Τ�, ���Ф�.
+ x, y = i.split(/ /); x = x.to_f; y = y.to_f
+ # ��ɸ���ѹ�����.
+ ca1.e("coords current #{x - 5} #{y - 5} #{x + 5} #{y + 5}")},
+ # x, y ��ɸ�����Ƕ��ڤä���Τ򥤥ƥ졼���ѿ����Ϥ��褦�˻���.
+ "%x %y"))
+ # rectangle �� bind ����.
+ ca1.e("bind", idr, "<B1-Motion>", c)
+
+ pack.e(ca1)
+ end
+end
+
+# test driver
+
+if ARGV.size == 0
+ print "#{$0} n ��, n �ĤΥ��󥿥ץ꥿��ư���ޤ�.\n"
+ n = 1
+else
+ n = ARGV[0].to_i
+end
+
+print "start\n"
+ip = []
+
+# ���󥿥ץ꥿, ���������å���������.
+for i in 1 .. n
+ ip.push(Test1.new())
+end
+
+# �Ѱդ��Ǥ����饤�٥�ȥ롼�פ�����.
+TclTk.mainloop()
+print "exit from mainloop\n"
+
+# ���󥿥ץ꥿�� GC ����뤫�Υƥ���.
+ip = []
+print "GC.start\n" if $DEBUG
+GC.start() if $DEBUG
+print "end\n"
+
+exit
+
+# end
diff --git a/ext/tcltklib/sample/sample2.rb b/ext/tcltklib/sample/sample2.rb
new file mode 100644
index 0000000000..969d8de09a
--- /dev/null
+++ b/ext/tcltklib/sample/sample2.rb
@@ -0,0 +1,449 @@
+#!/usr/local/bin/ruby
+#----------------------> pretty simple othello game <-----------------------
+# othello.rb
+#
+# version 0.3
+# maeda shugo ([email protected])
+#---------------------------------------------------------------------------
+
+# Sep. 17, 1997 modified by Y. Shigehiro for tcltk library
+# maeda shugo ([email protected]) ��ˤ��
+# (ruby/tk �ǽ񤫤�Ƥ���) ruby �Υ���ץ�ץ������
+# http://www.aianet.or.jp/~shugo/ruby/othello.rb.gz
+# �� tcltk �饤�֥���Ȥ��褦��, ����Ū���ѹ����Ƥߤޤ���.
+#
+# �ʤ�٤����ꥸ�ʥ��Ʊ���ˤʤ�褦�ˤ��Ƥ���ޤ�.
+
+require "observer"
+require "tcltk"
+$ip = TclTkInterpreter.new()
+$root = $ip.rootwidget()
+$button, $canvas, $checkbutton, $frame, $label, $pack, $update, $wm =
+ $ip.commands().indexes(
+ "button", "canvas", "checkbutton", "frame", "label", "pack", "update", "wm")
+
+class Othello
+
+ EMPTY = 0
+ BLACK = 1
+ WHITE = - BLACK
+
+ attr :in_com_turn
+ attr :game_over
+
+ class Board
+
+ include Observable
+
+ DIRECTIONS = [
+ [-1, -1], [-1, 0], [-1, 1],
+ [ 0, -1], [ 0, 1],
+ [ 1, -1], [ 1, 0], [ 1, 1]
+ ]
+
+ attr :com_disk, TRUE
+
+ def initialize(othello)
+ @othello = othello
+ reset
+ end
+
+ def notify_observers(*arg)
+ if @observer_peers != nil
+ super(*arg)
+ end
+ end
+
+ def reset
+ @data = [
+ [EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY],
+ [EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY],
+ [EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY],
+ [EMPTY, EMPTY, EMPTY, WHITE, BLACK, EMPTY, EMPTY, EMPTY],
+ [EMPTY, EMPTY, EMPTY, BLACK, WHITE, EMPTY, EMPTY, EMPTY],
+ [EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY],
+ [EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY],
+ [EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY, EMPTY]
+ ]
+ changed
+ notify_observers
+ end
+
+ def man_disk
+ return - @com_disk
+ end
+
+ def other_disk(disk)
+ return - disk
+ end
+
+ def get_disk(row, col)
+ return @data[row][col]
+ end
+
+ def reverse_to(row, col, my_disk, dir_y, dir_x)
+ y = row
+ x = col
+ begin
+ y += dir_y
+ x += dir_x
+ if y < 0 || x < 0 || y > 7 || x > 7 ||
+ @data[y][x] == EMPTY
+ return
+ end
+ end until @data[y][x] == my_disk
+ begin
+ @data[y][x] = my_disk
+ changed
+ notify_observers(y, x)
+ y -= dir_y
+ x -= dir_x
+ end until y == row && x == col
+ end
+
+ def put_disk(row, col, disk)
+ @data[row][col] = disk
+ changed
+ notify_observers(row, col)
+ DIRECTIONS.each do |dir|
+ reverse_to(row, col, disk, *dir)
+ end
+ end
+
+ def count_disk(disk)
+ num = 0
+ @data.each do |rows|
+ rows.each do |d|
+ if d == disk
+ num += 1
+ end
+ end
+ end
+ return num
+ end
+
+ def count_point_to(row, col, my_disk, dir_y, dir_x)
+ return 0 if @data[row][col] != EMPTY
+ count = 0
+ loop do
+ row += dir_y
+ col += dir_x
+ break if row < 0 || col < 0 || row > 7 || col > 7
+ case @data[row][col]
+ when my_disk
+ return count
+ when other_disk(my_disk)
+ count += 1
+ when EMPTY
+ break
+ end
+ end
+ return 0
+ end
+
+ def count_point(row, col, my_disk)
+ count = 0
+ DIRECTIONS.each do |dir|
+ count += count_point_to(row, col, my_disk, *dir)
+ end
+ return count
+ end
+
+ def corner?(row, col)
+ return (row == 0 && col == 0) ||
+ (row == 0 && col == 7) ||
+ (row == 7 && col == 0) ||
+ (row == 7 && col == 7)
+ end
+
+ def search(my_disk)
+ max = 0
+ max_row = nil
+ max_col = nil
+ for row in 0 .. 7
+ for col in 0 .. 7
+ buf = count_point(row, col, my_disk)
+ if (corner?(row, col) && buf > 0) || max < buf
+ max = buf
+ max_row = row
+ max_col = col
+ end
+ end
+ end
+ return max_row, max_col
+ end
+ end #--------------------------> class Board ends here
+
+ class BoardView < TclTkWidget
+
+ BACK_GROUND_COLOR = "DarkGreen"
+ HILIT_BG_COLOR = "green"
+ BORDER_COLOR = "black"
+ BLACK_COLOR = "black"
+ WHITE_COLOR = "white"
+ STOP_COLOR = "red"
+
+ attr :left
+ attr :top
+ attr :right
+ attr :bottom
+
+ class Square
+
+ attr :oval, TRUE
+ attr :row
+ attr :col
+
+ def initialize(view, row, col)
+ @view = view
+ @id = @view.e("create rectangle", *view.tk_rect(view.left + col,
+ view.top + row,
+ view.left + col + 1,
+ view.top + row + 1))
+ @row = row
+ @col = col
+ @view.e("itemconfigure", @id,
+ "-width 0.5m -outline #{BORDER_COLOR}")
+ @view.e("bind", @id, "<Any-Enter>", TclTkCallback.new($ip, proc{
+ if @oval == nil
+ view.e("itemconfigure", @id, "-fill #{HILIT_BG_COLOR}")
+ end
+ }))
+ @view.e("bind", @id, "<Any-Leave>", TclTkCallback.new($ip, proc{
+ view.e("itemconfigure", @id, "-fill #{BACK_GROUND_COLOR}")
+ }))
+ @view.e("bind", @id, "<ButtonRelease-1>", TclTkCallback.new($ip,
+ proc{
+ view.click_square(self)
+ }))
+ end
+
+ def blink(color)
+ @view.e("itemconfigure", @id, "-fill #{color}")
+ $update.e()
+ sleep(0.1)
+ @view.e("itemconfigure", @id, "-fill #{BACK_GROUND_COLOR}")
+ end
+ end #-----------------------> class Square ends here
+
+ def initialize(othello, board)
+ super($ip, $root, $canvas)
+ @othello = othello
+ @board = board
+ @board.add_observer(self)
+
+ @squares = Array.new(8)
+ for i in 0 .. 7
+ @squares[i] = Array.new(8)
+ end
+ @left = 1
+ @top = 0.5
+ @right = @left + 8
+ @bottom = @top + 8
+
+ i = self.e("create rectangle", *tk_rect(@left, @top, @right, @bottom))
+ self.e("itemconfigure", i,
+ "-width 1m -outline #{BORDER_COLOR} -fill #{BACK_GROUND_COLOR}")
+
+ for row in 0 .. 7
+ for col in 0 .. 7
+ @squares[row][col] = Square.new(self, row, col)
+ end
+ end
+
+ update
+ end
+
+ def tk_rect(left, top, right, bottom)
+ return left.to_s + "c", top.to_s + "c",
+ right.to_s + "c", bottom.to_s + "c"
+ end
+
+ def clear
+ each_square do |square|
+ if square.oval != nil
+ self.e("delete", square.oval)
+ square.oval = nil
+ end
+ end
+ end
+
+ def draw_disk(row, col, disk)
+ if disk == EMPTY
+ if @squares[row][col].oval != nil
+ self.e("delete", @squares[row][col].oval)
+ @squares[row][col].oval = nil
+ end
+ return
+ end
+
+ $update.e()
+ sleep(0.05)
+ oval = @squares[row][col].oval
+ if oval == nil
+ oval = self.e("create oval", *tk_rect(@left + col + 0.2,
+ @top + row + 0.2,
+ @left + col + 0.8,
+ @top + row + 0.8))
+ @squares[row][col].oval = oval
+ end
+ case disk
+ when BLACK
+ color = BLACK_COLOR
+ when WHITE
+ color = WHITE_COLOR
+ else
+ fail format("Unknown disk type: %d", disk)
+ end
+ self.e("itemconfigure", oval, "-outline #{color} -fill #{color}")
+ end
+
+ def update(row = nil, col = nil)
+ if row && col
+ draw_disk(row, col, @board.get_disk(row, col))
+ else
+ each_square do |square|
+ draw_disk(square.row, square.col,
+ @board.get_disk(square.row, square.col))
+ end
+ end
+ @othello.show_point
+ end
+
+ def each_square
+ @squares.each do |rows|
+ rows.each do |square|
+ yield(square)
+ end
+ end
+ end
+
+ def click_square(square)
+ if @othello.in_com_turn || @othello.game_over ||
+ @board.count_point(square.row,
+ square.col,
+ @board.man_disk) == 0
+ square.blink(STOP_COLOR)
+ return
+ end
+ @board.put_disk(square.row, square.col, @board.man_disk)
+ @othello.com_turn
+ end
+
+ private :draw_disk
+ public :update
+ end #----------------------> class BoardView ends here
+
+ def initialize
+ @msg_label = TclTkWidget.new($ip, $root, $label)
+ $pack.e(@msg_label)
+
+ @board = Board.new(self)
+ @board_view = BoardView.new(self, @board)
+ #### added by Y. Shigehiro
+ ## board_view ���礭�������ꤹ��.
+ x1, y1, x2, y2 = @board_view.e("bbox all").split(/ /).collect{|i| i.to_f}
+ @board_view.e("configure -width", x2 - x1)
+ @board_view.e("configure -height", y2 - y1)
+ ## scrollregion �����ꤹ��.
+ @board_view.e("configure -scrollregion {", @board_view.e("bbox all"),
+ "}")
+ #### �����ޤ�
+ $pack.e(@board_view, "-fill both -expand true")
+
+ panel = TclTkWidget.new($ip, $root, $frame)
+
+ @play_black = TclTkWidget.new($ip, panel, $checkbutton,
+ "-text {com is black} -command", TclTkCallback.new($ip, proc{
+ switch_side
+ }))
+ $pack.e(@play_black, "-side left")
+
+ quit = TclTkWidget.new($ip, panel, $button, "-text Quit -command",
+ TclTkCallback.new($ip, proc{
+ exit
+ }))
+ $pack.e(quit, "-side right -fill x")
+
+ reset = TclTkWidget.new($ip, panel, $button, "-text Reset -command",
+ TclTkCallback.new($ip, proc{
+ reset_game
+ }))
+ $pack.e(reset, "-side right -fill x")
+
+ $pack.e(panel, "-side bottom -fill x")
+
+# root = Tk.root
+ $wm.e("title", $root, "Othello")
+ $wm.e("iconname", $root, "Othello")
+
+ @board.com_disk = WHITE
+ @game_over = FALSE
+
+ TclTk.mainloop
+ end
+
+ def switch_side
+ if @in_com_turn
+ @play_black.e("toggle")
+ else
+ @board.com_disk = @board.man_disk
+ com_turn unless @game_over
+ end
+ end
+
+ def reset_game
+ if @board.com_disk == BLACK
+ @board.com_disk = WHITE
+ @play_black.e("toggle")
+ end
+ @board_view.clear
+ @board.reset
+ $wm.e("title", $root, "Othello")
+ @game_over = FALSE
+ end
+
+ def com_turn
+ @in_com_turn = TRUE
+ $update.e()
+ sleep(0.5)
+ begin
+ com_disk = @board.count_disk(@board.com_disk)
+ man_disk = @board.count_disk(@board.man_disk)
+ if @board.count_disk(EMPTY) == 0
+ if man_disk == com_disk
+ $wm.e("title", $root, "{Othello - Draw!}")
+ elsif man_disk > com_disk
+ $wm.e("title", $root, "{Othello - You Win!}")
+ else
+ $wm.e("title", $root, "{Othello - You Loose!}")
+ end
+ @game_over = TRUE
+ break
+ elsif com_disk == 0
+ $wm.e("title", $root, "{Othello - You Win!}")
+ @game_over = TRUE
+ break
+ elsif man_disk == 0
+ $wm.e("title", $root, "{Othello - You Loose!}")
+ @game_over = TRUE
+ break
+ end
+ row, col = @board.search(@board.com_disk)
+ break if row == nil || col == nil
+ @board.put_disk(row, col, @board.com_disk)
+ end while @board.search(@board.man_disk) == [nil, nil]
+ @in_com_turn = FALSE
+ end
+
+ def show_point
+ black = @board.count_disk(BLACK)
+ white = @board.count_disk(WHITE)
+ @msg_label.e("configure -text",
+ %Q/{#{format("BLACK: %.2d WHITE: %.2d", black, white)}}/)
+ end
+end #----------------------> class Othello ends here
+
+Othello.new
+
+#----------------------------------------------> othello.rb ends here
diff --git a/ext/tcltklib/tcltklib.c b/ext/tcltklib/tcltklib.c
new file mode 100644
index 0000000000..e7fe77d2b7
--- /dev/null
+++ b/ext/tcltklib/tcltklib.c
@@ -0,0 +1,216 @@
+/*
+ * tcltklib.c
+ * Aug. 27, 1997 Y. Shigehiro
+ * Oct. 24, 1997 Y. Matsumoto
+ */
+
+#include "ruby.h"
+#include "sig.h"
+#include <stdio.h>
+#include <string.h>
+#include <tcl.h>
+#include <tk.h>
+
+/* for debug */
+
+#define DUMP1(ARG1) if (debug) { fprintf(stderr, "tcltklib: %s\n", ARG1);}
+#define DUMP2(ARG1, ARG2) if (debug) { fprintf(stderr, "tcltklib: ");\
+fprintf(stderr, ARG1, ARG2); fprintf(stderr, "\n"); }
+/*
+#define DUMP1(ARG1)
+#define DUMP2(ARG1, ARG2)
+*/
+
+/* from tkAppInit.c */
+
+/*
+ * The following variable is a special hack that is needed in order for
+ * Sun shared libraries to be used for Tcl.
+ */
+
+extern int matherr();
+int *tclDummyMathPtr = (int *) matherr;
+
+/*---- module TclTkLib ----*/
+
+static VALUE thread_safe = Qnil;
+
+/* execute Tk_MainLoop */
+static VALUE
+lib_mainloop(VALUE self)
+{
+ int old_trapflg;
+ int flags = RTEST(thread_safe)?TCL_DONT_WAIT:0;
+
+ DUMP1("start Tk_Mainloop");
+ while (Tk_GetNumMainWindows() > 0) {
+ old_trapflg = trap_immediate;
+ trap_immediate = 1;
+ Tcl_DoOneEvent(flags);
+ trap_immediate = old_trapflg;
+ CHECK_INTS;
+ flags = (thread_safe == 0 || thread_safe == Qnil)?0:TCL_DONT_WAIT;
+ }
+ DUMP1("stop Tk_Mainloop");
+
+ return Qnil;
+}
+
+/*---- class TclTkIp ----*/
+struct tcltkip {
+ Tcl_Interp *ip; /* the interpreter */
+ int return_value; /* return value */
+};
+
+/* Tcl command `ruby' */
+static VALUE
+ip_eval_rescue(VALUE *failed, VALUE einfo)
+{
+ *failed = einfo;
+ return Qnil;
+}
+
+static int
+ip_ruby(ClientData clientData, Tcl_Interp *interp, int argc, char *argv[])
+{
+ VALUE res;
+ int old_trapflg;
+ VALUE failed = 0;
+
+ /* ruby command has 1 arg. */
+ if (argc != 2) {
+ ArgError("wrong # of arguments (%d for 1)", argc);
+ }
+
+ /* evaluate the argument string by ruby */
+ DUMP2("rb_eval_string(%s)", argv[1]);
+ old_trapflg = trap_immediate;
+ trap_immediate = 0;
+ res = rb_rescue(rb_eval_string, argv[1], ip_eval_rescue, &failed);
+ trap_immediate = old_trapflg;
+
+ if (failed) {
+ Tcl_AppendResult(interp, RSTRING(failed)->ptr, (char*)NULL);
+ return TCL_ERROR;
+ }
+
+ /* result must be string or nil */
+ if (NIL_P(res)) {
+ DUMP1("(rb_eval_string result) nil");
+ return TCL_OK;
+ }
+ Check_Type(res, T_STRING);
+
+ /* copy result to the tcl interpreter */
+ DUMP2("(rb_eval_string result) %s", RSTRING(res)->ptr);
+ DUMP1("Tcl_AppendResult");
+ Tcl_AppendResult(interp, RSTRING(res)->ptr, (char *)NULL);
+
+ return TCL_OK;
+}
+
+/* destroy interpreter */
+static void
+ip_free(struct tcltkip *ptr)
+{
+ DUMP1("Tcl_DeleteInterp");
+ Tcl_DeleteInterp(ptr->ip);
+}
+
+/* create and initialize interpreter */
+static VALUE
+ip_new(VALUE self)
+{
+ struct tcltkip *ptr; /* tcltkip data struct */
+ VALUE obj; /* newly created object */
+
+ /* create object */
+ obj = Data_Make_Struct(self, struct tcltkip, 0, ip_free, ptr);
+ ptr->return_value = 0;
+
+ /* from Tk_Main() */
+ DUMP1("Tcl_CreateInterp");
+ ptr->ip = Tcl_CreateInterp();
+
+ /* from Tcl_AppInit() */
+ DUMP1("Tcl_Init");
+ if (Tcl_Init(ptr->ip) == TCL_ERROR) {
+ Fail("Tcl_Init");
+ }
+ DUMP1("Tk_Init");
+ if (Tk_Init(ptr->ip) == TCL_ERROR) {
+ Fail("Tk_Init");
+ }
+ DUMP1("Tcl_StaticPackage(\"Tk\")");
+ Tcl_StaticPackage(ptr->ip, "Tk", Tk_Init,
+ (Tcl_PackageInitProc *) NULL);
+
+ /* add ruby command to the interpreter */
+ DUMP1("Tcl_CreateCommand(\"ruby\")");
+ Tcl_CreateCommand(ptr->ip, "ruby", ip_ruby, (ClientData *)NULL,
+ (Tcl_CmdDeleteProc *)NULL);
+
+ return obj;
+}
+
+/* eval string in tcl by Tcl_Eval() */
+static VALUE
+ip_eval(VALUE self, VALUE str)
+{
+ char *buf; /* Tcl_Eval requires re-writable string region */
+ struct tcltkip *ptr; /* tcltkip data struct */
+
+ /* get the data struct */
+ Data_Get_Struct(self, struct tcltkip, ptr);
+
+ /* call Tcl_Eval() */
+ Check_Type(str, T_STRING);
+ buf = ALLOCA_N(char,RSTRING(str)->len+1);
+ strcpy(buf, RSTRING(str)->ptr);
+ DUMP2("Tcl_Eval(%s)", buf);
+ ptr->return_value = Tcl_Eval(ptr->ip, buf);
+ if (ptr->return_value == TCL_ERROR) {
+ Fail(ptr->ip->result);
+ }
+ DUMP2("(TCL_Eval result) %d", ptr->return_value);
+
+ /* pass back the result (as string) */
+ return(str_new2(ptr->ip->result));
+}
+
+/* get return code from Tcl_Eval() */
+static VALUE
+ip_retval(VALUE self)
+{
+ struct tcltkip *ptr; /* tcltkip data struct */
+
+ /* get the data strcut */
+ Data_Get_Struct(self, struct tcltkip, ptr);
+
+ return (INT2FIX(ptr->return_value));
+}
+
+/*---- initialization ----*/
+void Init_tcltklib()
+{
+ extern VALUE rb_argv0; /* the argv[0] */
+
+ VALUE lib = rb_define_module("TclTkLib");
+ VALUE ip = rb_define_class("TclTkIp", cObject);
+
+ rb_define_module_function(lib, "mainloop", lib_mainloop, 0);
+
+ rb_define_singleton_method(ip, "new", ip_new, 0);
+ rb_define_method(ip, "_eval", ip_eval, 1);
+ rb_define_method(ip, "_return_value", ip_retval, 0);
+ rb_define_method(ip, "mainloop", lib_mainloop, 0);
+
+ /*---- initialize tcl/tk libraries ----*/
+ /* from Tk_Main() */
+ DUMP1("Tcl_FindExecutable");
+ Tcl_FindExecutable(RSTRING(rb_argv0)->ptr);
+
+ rb_define_variable("$tk_thread_safe", &thread_safe);
+}
+
+/* eof */