This commit was manufactured by cvs2svn to create branch 'ruby_1_8'.

git-svn-id: svn+ssh://ci.ruby-lang.org/ruby/branches/ruby_1_8@7877 b2dd03c8-39d4-4d8f-98ff-823fe69b080e

ext/tk/README.ActiveTcl

@@ -0,0 +1,49 @@
+ActiveTcl is ActiveState's quality-assured distribution of Tcl. 
+
+# see <http://www.activestate.com/Products/ActiveTcl/>
+#     <http://www.tcl.tk/>
+
+If you want to use ActiveTcl binary package as the Tcl/Tk libraries, 
+please use the following configure options.
+
+   --with-tcl-dir=<ActiveTcl_root>
+   --with-tk-dir=<ActiveTcl_root>
+
+And use the followings if you need.
+
+   --with-tcllib=<libname>
+   --with-tklib=<libname>
+   --enable-tcltk-stubs
+
+For example, when you install ActiveTcl-8.4.x to '/usr/local/ActiveTcl', 
+
+   configure --with-tcl-dir=/usr/local/ActiveTcl/  \
+             --with-tk-dir=/usr/local/ActiveTcl/   \
+             --with-tcllib=tclstub8.4              \
+             --with-tklib=tkstub8.4                \
+             --enable-tcltk-stubs
+
+It depends on your environment that you have to add the directory of 
+ActiveTcl's libraries to your library path when execute Ruby/Tk. 
+One of the way is to add entries to TCLLIBPATH environment variable, 
+and one of the others add to LD_LIBRARY_PATH environment variable
+
+Probably, using TCLLIBPATH is better. The value is appended at the 
+head of Tcl's 'auto_path' variable. You can see the value of the 
+variable by using 'Tk::AUTO_PATH.value' or 'Tk::AUTO_PATH.list'.
+
+For example, on Linux, one of the ways is to use LD_LIBRARY_PATH 
+environment variable. 
+-------------------------------------------------------------------------
+ [bash]$ LD_LIBRARY_PATH=/usr/local/ActiveTcl/lib:$LD_LIBRARY_PATH \
+         ruby your-Ruby/Tk-script
+
+ [bash]$ LD_LIBRARY_PATH=/usr/local/ActiveTcl/lib:$LD_LIBRARY_PATH irb
+-------------------------------------------------------------------------
+Based on it, the Tcl interpreter changes auto_path variable's value.
+
+Then, you'll be able to use Tcl/Tk extension libraries included in the
+ActiveTcl package (e.g. call TkPackage.require('BWidget'), and then,
+use functions/widgets of BWidget extention). 
+
+                                  Hidetoshi NAGAI (nagai@ai.kyutech.ac.jp)

ext/tk/lib/tcltk.rb

@@ -0,0 +1,367 @@
+# tof
+
+#### tcltk library, more direct manipulation of tcl/tk
+####    Sep. 5, 1997    Y. Shigehiro
+
+require "tcltklib"
+
+################
+
+# module TclTk: collection of tcl/tk utilities (supplies namespace.)
+module TclTk
+
+  # initialize Hash to hold unique symbols and such
+  @namecnt = {}
+
+  # initialize Hash to hold callbacks
+  @callback = {}
+end
+
+# TclTk.mainloop(): call TclTkLib.mainloop()
+def TclTk.mainloop()
+  print("mainloop: start\n") if $DEBUG
+  TclTkLib.mainloop()
+  print("mainloop: end\n") if $DEBUG
+end
+
+# TclTk.deletecallbackkey(ca): remove callback from TclTk module
+#     this does not remove callbacks from tcl/tk interpreter
+#     without calling this method, TclTkInterpreter will not be GCed
+#   ca: callback(TclTkCallback)
+def TclTk.deletecallbackkey(ca)
+  print("deletecallbackkey: ", ca.to_s(), "\n") if $DEBUG
+  @callback.delete(ca.to_s)
+end
+
+# TclTk.dcb(ca, wid, W): call TclTk.deletecallbackkey() for each callbacks
+#     in an array.
+#     this is for callback for top-level <Destroy>
+#   ca: array of callbacks(TclTkCallback)
+#   wid: top-level widget(TclTkWidget)
+#   w: information about window given by %W(String)
+def TclTk.dcb(ca, wid, w)
+  if wid.to_s() == w
+    ca.each{|i|
+      TclTk.deletecallbackkey(i)
+    }
+  end
+end
+
+# TclTk._addcallback(ca): register callback
+#   ca: callback(TclTkCallback)
+def TclTk._addcallback(ca)
+  print("_addcallback: ", ca.to_s(), "\n") if $DEBUG
+  @callback[ca.to_s()] = ca
+end
+
+# TclTk._callcallback(key, arg): invoke registered callback
+#   key: key to select callback (to_s value of the TclTkCallback)
+#   arg: parameter from tcl/tk interpreter
+def TclTk._callcallback(key, arg)
+  print("_callcallback: ", @callback[key].inspect, "\n") if $DEBUG
+  @callback[key]._call(arg)
+  # throw out callback value
+  # should return String to satisfy rb_eval_string()
+  return ""
+end
+
+# TclTk._newname(prefix): generate unique name(String)
+#   prefix: prefix of the unique name
+def TclTk._newname(prefix)
+  # generated name counter is stored in @namecnt
+  if !@namecnt.key?(prefix)
+    # first appearing prefix, initialize
+    @namecnt[prefix] = 1
+  else
+    # already appeared prefix, generate next name
+    @namecnt[prefix] += 1
+  end
+  return "#{prefix}#{@namecnt[prefix]}"
+end
+
+################
+
+# class TclTkInterpreter: tcl/tk interpreter
+class TclTkInterpreter
+
+  # initialize(): 
+  def initialize()
+    # generate interpreter object
+    @ip = TclTkIp.new()
+
+    # add ruby_fmt command to tcl interpreter
+    # ruby_fmt command format arguments by `format' and call `ruby' command
+    # (notice ruby command receives only one argument)
+    if $DEBUG
+      @ip._eval("proc ruby_fmt {fmt args} { puts \"ruby_fmt: $fmt $args\" ; set cmd [list ruby [format $fmt $args]] ; uplevel $cmd }")
+    else
+      @ip._eval("proc ruby_fmt {fmt args} { set cmd [list ruby [format $fmt $args]] ; uplevel $cmd }")
+    end
+
+    # @ip._get_eval_string(*args): generate string to evaluate in tcl interpreter
+    #   *args: script which is going to be evaluated under tcl/tk
+    def @ip._get_eval_string(*args)
+      argstr = ""
+      args.each{|arg|
+        argstr += " " if argstr != ""
+        # call to_eval if it is defined
+        if (arg.respond_to?(:to_eval))
+          argstr += arg.to_eval()
+        else
+          # call to_s unless defined
+          argstr += arg.to_s()
+        end
+      }
+      return argstr
+    end
+
+    # @ip._eval_args(*args): evaluate string under tcl/tk interpreter
+    #     returns result string.
+    #   *args: script which is going to be evaluated under tcl/tk
+    def @ip._eval_args(*args)
+      # calculate the string to eval in the interpreter
+      argstr = _get_eval_string(*args)
+
+      # evaluate under the interpreter
+      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
+
+    # generate tcl/tk command object and register in the hash
+    @commands = {}
+    # for all commands registered in tcl/tk interpreter:
+    @ip._eval("info command").split(/ /).each{|comname|
+      if comname =~ /^[.]/
+        # if command is a widget (path), generate TclTkWidget,
+        # and register it in the hash
+        @commands[comname] = TclTkWidget.new(@ip, comname)
+      else
+        # otherwise, generate TclTkCommand
+        @commands[comname] = TclTkCommand.new(@ip, comname)
+      end
+    }
+  end
+
+  # commands(): returns hash of the tcl/tk commands
+  def commands()
+    return @commands
+  end
+
+  # rootwidget(): returns root widget(TclTkWidget)
+  def rootwidget()
+    return @commands["."]
+  end
+
+  # _tcltkip(): returns @ip(TclTkIp)
+  def _tcltkip()
+    return @ip
+  end
+
+  # method_missing(id, *args): execute undefined method as tcl/tk command
+  #   id: method symbol
+  #   *args: method arguments
+  def method_missing(id, *args)
+    # if command named by id registered, then execute it
+    if @commands.key?(id.id2name)
+      return @commands[id.id2name].e(*args)
+    else
+      # otherwise, exception
+      super
+    end
+  end
+end
+
+# class TclTkObject: base class of the tcl/tk objects
+class TclTkObject
+
+  # initialize(ip, exp): 
+  #   ip: interpreter(TclTkIp)
+  #   exp: tcl/tk representation
+  def initialize(ip, exp)
+    fail("type is not TclTkIp") if !ip.kind_of?(TclTkIp)
+    @ip = ip
+    @exp = exp
+  end
+
+  # to_s(): returns tcl/tk representation
+  def to_s()
+    return @exp
+  end
+end
+
+# class TclTkCommand: tcl/tk commands
+# you should not call TclTkCommand.new()
+# commands are created by TclTkInterpreter:initialize()
+class TclTkCommand < TclTkObject
+
+  # e(*args): execute command.  returns String (e is for exec or eval)
+  #   *args: command arguments
+  def e(*args)
+    return @ip._eval_args(to_s(), *args)
+  end
+end
+
+# class TclTkLibCommand: tcl/tk commands in the library
+class TclTkLibCommand < TclTkCommand
+
+  # initialize(ip, name): 
+  #   ip: interpreter(TclTkInterpreter)
+  #   name: command name (String)
+  def initialize(ip, name)
+    super(ip._tcltkip, name)
+  end
+end
+
+# class TclTkVariable: tcl/tk variable
+class TclTkVariable < TclTkObject
+
+  # initialize(interp, dat): 
+  #   interp: interpreter(TclTkInterpreter)
+  #   dat: the value to set(String)
+  #       if nil, not initialize variable
+  def initialize(interp, dat)
+    # auto-generate tcl/tk representation (variable name)
+    exp = TclTk._newname("v_")
+    # initialize TclTkObject
+    super(interp._tcltkip(), exp)
+    # safe this for `set' command
+    @set = interp.commands()["set"]
+    # set value
+    set(dat) if dat
+  end
+
+  # although you can set/refer variable by using set in tcl/tk,
+  # we provide the method for accessing variables
+
+  # set(data): set tcl/tk variable using `set'
+  #   data: new value
+  def set(data)
+    @set.e(to_s(), data.to_s())
+  end
+
+  # get(): read tcl/tk variable(String) using `set'
+  def get()
+    return @set.e(to_s())
+  end
+end
+
+# class TclTkWidget: tcl/tk widget
+class TclTkWidget < TclTkCommand
+
+  # initialize(*args): 
+  #   *args: parameters
+  def initialize(*args)
+    if args[0].kind_of?(TclTkIp)
+      # in case the 1st argument is TclTkIp:
+
+      # Wrap tcl/tk widget by TclTkWidget
+      # (used in TclTkInterpreter#initialize())
+
+      # need two arguments
+      fail("illegal # of parameter") if args.size != 2
+
+      # ip: interpreter(TclTkIp)
+      # exp: tcl/tk representation
+      ip, exp = args
+
+      # initialize TclTkObject
+      super(ip, exp)
+    elsif args[0].kind_of?(TclTkInterpreter)
+      # in case 1st parameter is TclTkInterpreter:
+
+      # generate new widget from parent widget
+
+      # interp: interpreter(TclTkInterpreter)
+      # parent: parent widget
+      # command: widget generating tk command(label Åù)
+      # *args: argument to the command 
+      interp, parent, command, *args = args
+
+      # generate widget name
+      exp = parent.to_s()
+      exp += "." if exp !~ /[.]$/
+      exp += TclTk._newname("w_")
+      # initialize TclTkObject
+      super(interp._tcltkip(), exp)
+      # generate widget
+      res = @ip._eval_args(command, exp, *args)
+#      fail("can't create Widget") if res != exp
+      # for tk_optionMenu, it is legal res != exp
+    else
+      fail("first parameter is not TclTkInterpreter")
+    end
+  end
+end
+
+# class TclTkCallback: tcl/tk callbacks
+class TclTkCallback < TclTkObject
+
+  # initialize(interp, pr, arg): 
+  #   interp: interpreter(TclTkInterpreter)
+  #   pr: callback procedure(Proc)
+  #   arg: string to pass as block parameters of pr
+  #       bind command of tcl/tk uses % replacement for parameters
+  #       pr can receive replaced data using block parameter
+  #       its format is specified by arg string
+  #       You should not specify arg for the command like 
+  #       scrollbar with -command option, which receives parameters
+  #       without specifying any replacement
+  def initialize(interp, pr, arg = nil)
+    # auto-generate tcl/tk representation (variable name)
+    exp = TclTk._newname("c_")
+    # initialize TclTkObject
+    super(interp._tcltkip(), exp)
+    # save parameters
+    @pr = pr
+    @arg = arg
+    # register in the module
+    TclTk._addcallback(self)
+  end
+
+  # to_eval(): retuens string representation for @ip._eval_args
+  def to_eval()
+    if @arg
+      # bind replaces %s before calling ruby_fmt, so %%s is used
+      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): invoke callback
+  #   arg: callback parameter
+  def _call(arg)
+    @pr.call(arg)
+  end
+end
+
+# class TclTkImage: tcl/tk images
+class TclTkImage < TclTkCommand
+
+  # initialize(interp, t, *args): 
+  #     generating image is done by TclTkImage.new()
+  #     destrying is done by image delete (inconsistent, sigh)
+  #   interp: interpreter(TclTkInterpreter)
+  #   t: image type (photo, bitmap, etc.)
+  #   *args: command argument
+  def initialize(interp, t, *args)
+    # auto-generate tcl/tk representation
+    exp = TclTk._newname("i_")
+    # initialize TclTkObject
+    super(interp._tcltkip(), exp)
+    # generate image
+    res = @ip._eval_args("image create", t, exp, *args)
+    fail("can't create Image") if res != exp
+  end
+end
+
+# eof

ext/tk/old-README.tcltklib.eucj

@@ -0,0 +1,159 @@
+(tof)
+                                    2003/06/19  Hidetoshi NAGAI
+
+本ドキュメントには古い tcltk ライブラリ，tcltklib ライブラリの説明
+が含まれていますが，その記述内容は古いものとなっています．
+
+まず，現在の Ruby/Tk の中心である tk.rb は wish を呼び出したりはせ
+ず，tcltklib ライブラリを wrap して動作するものとなっています．その
+ため，古い説明記述で述べられているようなプロセス間通信によるオーバ
+ヘッドは存在しません．
+
+現在の tcltklib ライブラリでも，Tcl/Tk の C ライブラリをリンクして
+直接に動かすことで，オーバヘッドを押さえつつ Tcl/Tk インタープリタ
+のほぼ全機能（拡張ライブラリを含む）を使える点は同じです．しかし，
+その役割はほぼ「tk.rb 以下のライブラリを効果的に働かせるためのもの」
+と見なされており，その目的でメンテナンスされています．
+
+tk.rb の高機能化に伴って，中水準のライブラリである tcltk ライブラリ
+（tcltk.rb）はその存在意義を減じており，現在ではメンテナンスは行わ
+れていません．
+
+なお，古い説明ではバインディングにおけるスクリプトの追加はできないこ
+ととなっていますが，現在の tk.rb ではこれも可能であることを補足して
+おきます．
+
+以下がライブラリの古い説明文書です．
+==============================================================
+	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 (shugo@po.aianet.ne.jp) 氏による
+    (`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 インタプリタで可能なことは
+
+	ほとんど
+
+   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)

ext/tk/sample/tcltklib/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

ext/tk/sample/tcltklib/lines1.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

ext/tk/sample/tcltklib/lines2.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

ext/tk/sample/tcltklib/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

ext/tk/sample/tcltklib/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

ext/tk/sample/tcltklib/safeTk.rb

@@ -0,0 +1,22 @@
+#!/usr/bin/env ruby
+require 'tcltklib'
+
+master = TclTkIp.new
+slave_name = 'slave0'
+slave = master.create_slave(slave_name, true)
+master._eval("::safe::interpInit #{slave_name}")
+master._eval("::safe::loadTk #{slave_name}")
+
+master._invoke('label', '.l1', '-text', 'master')
+master._invoke('pack', '.l1', '-padx', '30', '-pady', '50')
+master._eval('label .l2 -text {root widget of master-ip}')
+master._eval('pack .l2 -padx 30 -pady 50')
+
+slave._invoke('label', '.l1', '-text', 'slave')
+slave._invoke('pack', '.l1', '-padx', '30', '-pady', '50')
+slave._eval('label .l2 -text {root widget of slave-ip}')
+slave._eval('pack .l2 -padx 30 -pady 20')
+slave._eval('label .l3 -text {( container frame widget of master-ip )}')
+slave._eval('pack .l3 -padx 30 -pady 20')
+
+TclTkLib.mainloop

ext/tk/sample/tcltklib/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"

ext/tk/sample/tcltklib/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.values_at(
+      "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().values_at(
+      "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().values_at(
+      "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().values_at(
+      "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().values_at("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().values_at(
+      "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().values_at(
+      "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().values_at(
+      "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().values_at(
+      "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().values_at(
+      "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().values_at(
+      "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().values_at(
+      "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().values_at(
+      "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().values_at(
+      "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().values_at("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

ext/tk/sample/tcltklib/sample2.rb

@@ -0,0 +1,451 @@
+#!/usr/local/bin/ruby
+#----------------------> pretty simple othello game <-----------------------
+# othello.rb
+#
+# version 0.3
+# maeda shugo (shuto@po.aianet.ne.jp)
+#---------------------------------------------------------------------------
+
+#       Sep. 17, 1997   modified by Y. Shigehiro for tcltk library
+#          maeda shugo (shugo@po.aianet.ne.jp) 氏による
+#          (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().values_at(
+   "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) \
+                            << "-fill #{BACK_GROUND_COLOR}") )
+            @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

ext/tk/tkutil/.cvsignore

@@ -0,0 +1,3 @@
+Makefile
+*.log
+*.def

ext/tk/tkutil/depend

@@ -0,0 +1 @@
+tkutil.o: tkutil.c $(hdrdir)/ruby.h $(topdir)/config.h $(hdrdir)/defines.h

lib/rss/image.rb

@@ -0,0 +1,216 @@
+require 'rss/1.0'
+require 'rss/dublincore'
+
+module RSS
+
+  IMAGE_PREFIX = 'image'
+  IMAGE_URI = 'http://web.resource.org/rss/1.0/modules/image/'
+
+  RDF.install_ns(IMAGE_PREFIX, IMAGE_URI)
+
+  module ImageModelUtils
+    def validate_one_tag_name(name, tags)
+      invalid = tags.find {|tag| tag != name}
+      raise UnknownTagError.new(invalid, IMAGE_URI) if invalid
+      raise TooMuchTagError.new(name, tag_name) if tags.size > 1
+    end
+  end
+  
+  module ImageItemModel
+    include ImageModelUtils
+    extend BaseModel
+
+    def self.append_features(klass)
+      super
+
+      klass.install_have_child_element("#{IMAGE_PREFIX}_item")
+    end
+
+    def image_validate(tags)
+      validate_one_tag_name("item", tags)
+    end
+    
+    class Item < Element
+      include RSS10
+      include DublinCoreModel
+
+      class << self
+        def required_prefix
+          IMAGE_PREFIX
+        end
+        
+        def required_uri
+          IMAGE_URI
+        end
+      end
+      
+      [
+        ["about", ::RSS::RDF::URI, true],
+        ["resource", ::RSS::RDF::URI, false],
+      ].each do |name, uri, required|
+        install_get_attribute(name, uri, required)
+      end
+
+      %w(width height).each do |tag|
+        full_name = "#{IMAGE_PREFIX}_#{tag}"
+        install_text_element(full_name)
+        BaseListener.install_get_text_element(tag, IMAGE_URI, "#{full_name}=")
+      end
+
+      def initialize(about=nil, resource=nil)
+        super()
+        @about = about
+        @resource = resource
+      end
+
+      def full_name
+        tag_name_with_prefix(IMAGE_PREFIX)
+      end
+      
+      def to_s(need_convert=true, indent=calc_indent)
+        rv = tag(indent) do |next_indent|
+          [
+            other_element(false, next_indent),
+          ]
+        end
+        rv = convert(rv) if need_convert
+        rv
+      end
+
+      alias _image_width= image_width=
+      def image_width=(new_value)
+        if @do_validate
+          self._image_width = Integer(new_value)
+        else
+          self._image_width = new_value.to_i
+        end
+      end
+
+      alias _image_height= image_height=
+      def image_height=(new_value)
+        if @do_validate
+          self._image_height = Integer(new_value)
+        else
+          self._image_height = new_value.to_i
+        end
+      end
+
+      alias width= image_width=
+      alias width image_width
+      alias height= image_height=
+      alias height image_height
+
+      private
+      def _tags
+        [
+          [IMAGE_URI, 'width'],
+          [IMAGE_URI, 'height'],
+        ].delete_if do |x|
+          send(x[1]).nil?
+        end
+      end
+        
+      def _attrs
+        [
+          ["#{::RSS::RDF::PREFIX}:about", true, "about"],
+          ["#{::RSS::RDF::PREFIX}:resource", false, "resource"],
+        ]
+      end
+
+      def maker_target(target)
+        target.image_item
+      end
+
+      def setup_maker_attributes(item)
+        item.about = self.about
+        item.resource = self.resource
+      end
+    end
+  end
+  
+  module ImageFaviconModel
+    include ImageModelUtils
+    extend BaseModel
+    
+    def self.append_features(klass)
+      super
+
+      unless klass.class == Module
+        klass.install_have_child_element("#{IMAGE_PREFIX}_favicon")
+      end
+    end
+
+    def image_validate(tags)
+      validate_one_tag_name("favicon", tags)
+    end
+    
+    class Favicon < Element
+      include RSS10
+      include DublinCoreModel
+
+      class << self
+        def required_prefix
+          IMAGE_PREFIX
+        end
+        
+        def required_uri
+          IMAGE_URI
+        end
+      end
+      
+      [
+        ["about", ::RSS::RDF::URI, true],
+        ["size", IMAGE_URI, true],
+      ].each do |name, uri, required|
+        install_get_attribute(name, uri, required)
+      end
+
+      alias image_size= size=
+      alias image_size size
+
+      def initialize(about=nil, size=nil)
+        super()
+        @about = about
+        @size = size
+      end
+
+      def full_name
+        tag_name_with_prefix(IMAGE_PREFIX)
+      end
+      
+      def to_s(need_convert=true, indent=calc_indent)
+        rv = tag(indent) do |next_indent|
+          [
+            other_element(false, next_indent),
+          ]
+        end
+        rv = convert(rv) if need_convert
+        rv
+      end
+
+      private
+      def _attrs
+        [
+          ["#{::RSS::RDF::PREFIX}:about", true, "about"],
+          ["#{IMAGE_PREFIX}:size", true, "size"],
+        ]
+      end
+
+      def maker_target(target)
+        target.image_favicon
+      end
+
+      def setup_maker_attributes(favicon)
+        favicon.about = self.about
+        favicon.size = self.size
+      end
+    end
+
+  end
+
+  class RDF
+    class Channel; include ImageFaviconModel; end
+    class Item; include ImageItemModel; end
+  end
+
+end

lib/rss/maker/image.rb

@@ -0,0 +1,136 @@
+require 'rss/image'
+require 'rss/maker/1.0'
+require 'rss/maker/dublincore'
+
+module RSS
+  module Maker
+    module ImageItemModel
+      def self.append_features(klass)
+        super
+
+        name = "#{RSS::IMAGE_PREFIX}_item"
+        klass.add_need_initialize_variable(name, "make_#{name}")
+        klass.add_other_element(name)
+        klass.__send__(:attr_reader, name)
+        klass.module_eval(<<-EOC, __FILE__, __LINE__)
+          def setup_#{name}(rss, current)
+            if @#{name}
+              @#{name}.to_rss(rss, current)
+            end
+          end
+
+          def make_#{name}
+            self.class::#{Utils.to_class_name(name)}.new(@maker)
+          end
+EOC
+      end
+
+      class ImageItemBase
+        include Base
+        include Maker::DublinCoreModel
+
+        attr_accessor :about, :resource, :image_width, :image_height
+        add_need_initialize_variable(:about, :resource)
+        add_need_initialize_variable(:image_width, :image_height)
+        alias width= image_width=
+        alias width image_width
+        alias height= image_height=
+        alias height image_height
+
+        def have_required_values?
+          @about
+        end
+      end
+    end
+
+    module ImageFaviconModel
+      def self.append_features(klass)
+        super
+
+        name = "#{RSS::IMAGE_PREFIX}_favicon"
+        klass.add_need_initialize_variable(name, "make_#{name}")
+        klass.add_other_element(name)
+        klass.__send__(:attr_reader, name)
+        klass.module_eval(<<-EOC, __FILE__, __LINE__)
+          def setup_#{name}(rss, current)
+            if @#{name}
+              @#{name}.to_rss(rss, current)
+            end
+          end
+
+          def make_#{name}
+            self.class::#{Utils.to_class_name(name)}.new(@maker)
+          end
+EOC
+      end
+
+      class ImageFaviconBase
+        include Base
+        include Maker::DublinCoreModel
+
+        attr_accessor :about, :image_size
+        add_need_initialize_variable(:about, :image_size)
+        alias size image_size
+        alias size= image_size=
+
+        def have_required_values?
+          @about and @image_size
+        end
+      end
+    end
+
+    class ChannelBase; include Maker::ImageFaviconModel; end
+    
+    class ItemsBase
+      class ItemBase; include Maker::ImageItemModel; end
+    end
+
+    class RSS10
+      class Items
+        class Item
+          class ImageItem < ImageItemBase
+            def to_rss(rss, current)
+              if @about
+                item = ::RSS::ImageItemModel::Item.new(@about, @resource)
+                setup_values(item)
+                current.image_item = item
+              end
+            end
+          end
+        end
+      end
+      
+      class Channel
+        class ImageFavicon < ImageFaviconBase
+          def to_rss(rss, current)
+            if @about and @image_size
+              args = [@about, @image_size]
+              favicon = ::RSS::ImageFaviconModel::Favicon.new(*args)
+              setup_values(favicon)
+              current.image_favicon = favicon
+            end
+          end
+        end
+      end
+    end
+
+    class RSS09
+      class Items
+        class Item
+          class ImageItem < ImageItemBase
+            def to_rss(*args)
+            end
+          end
+        end
+      end
+      
+      class Channel
+        class ImageFavicon < ImageFaviconBase
+          def to_rss(*args)
+          end
+        end
+      end
+    end
+
+  end
+end

test/rss/test_image.rb

@@ -0,0 +1,165 @@
+require "cgi"
+require "rexml/document"
+
+require "rss-testcase"
+
+require "rss/1.0"
+require "rss/image"
+
+module RSS
+  class TestImage < TestCase
+
+    def setup
+      @prefix = "image"
+      @uri = "http://web.resource.org/rss/1.0/modules/image/"
+
+      @favicon_attrs = {
+        "rdf:about" => "http://www.kuro5hin.org/favicon.ico",
+        "#{@prefix}:size" => "small",
+      }
+      @favicon_contents = {"dc:title" => "Kuro5hin",}
+      @items = [
+        [
+          {
+            "rdf:about" => "http://www.example.org/item.png",
+            "rdf:resource" => "http://www.example.org/item",
+          },
+          {
+            "dc:title" => "Example Image",
+            "#{@prefix}:width" => 100,
+            "#{@prefix}:height" => 65,
+          },
+        ],
+        [
+          {
+            "rdf:about" => "http://www.kuro5hin.org/images/topics/culture.jpg",
+          },
+          {
+            "dc:title" => "Culture",
+            "#{@prefix}:width" => 80,
+            "#{@prefix}:height" => 50,
+          },
+        ]
+      ]
+
+
+      @channel_nodes = make_element("#{@prefix}:favicon",
+                                    @favicon_attrs,
+                                    @favicon_contents)
+      items = ""
+      @items.each do |attrs, contents|
+        image_item = make_element("#{@prefix}:item", attrs, contents)
+        items << make_item(image_item)
+      end
+
+      ns = {
+        @prefix => @uri,
+        DC_PREFIX => DC_URI,
+      }
+      @rss_source = make_RDF(<<-EOR, ns)
+#{make_channel(@channel_nodes)}
+#{make_image}
+#{items}
+#{make_textinput}
+EOR
+
+      @rss = Parser.parse(@rss_source)
+    end
+  
+    def test_parser
+      assert_nothing_raised do
+        Parser.parse(@rss_source)
+      end
+    
+      assert_too_much_tag("favicon", "channel") do
+        Parser.parse(make_RDF(<<-EOR, {@prefix => @uri}))
+#{make_channel(@channel_nodes * 2)}
+#{make_item}
+EOR
+      end
+    end
+  
+    def test_favicon_accessor
+      favicon = @rss.channel.image_favicon
+      [
+        %w(about rdf:about http://example.com/favicon.ico),
+        %w(size image:size large),
+        %w(image_size image:size medium),
+      ].each do |name, full_name, new_value|
+        assert_equal(@favicon_attrs[full_name], favicon.send(name))
+        favicon.send("#{name}=", new_value)
+        assert_equal(new_value, favicon.send(name))
+        favicon.send("#{name}=", @favicon_attrs[full_name])
+        assert_equal(@favicon_attrs[full_name], favicon.send(name))
+      end
+
+      [
+        %w(dc_title dc:title sample-favicon),
+      ].each do |name, full_name, new_value|
+        assert_equal(@favicon_contents[full_name], favicon.send(name))
+        favicon.send("#{name}=", new_value)
+        assert_equal(new_value, favicon.send(name))
+        favicon.send("#{name}=", @favicon_contents[full_name])
+        assert_equal(@favicon_contents[full_name], favicon.send(name))
+      end
+    end
+
+    def test_item_accessor
+      @rss.items.each_with_index do |item, i|
+        image_item = item.image_item
+        attrs, contents = @items[i]
+        [
+          %w(about rdf:about http://example.com/image.png),
+          %w(resource rdf:resource http://example.com/),
+        ].each do |name, full_name, new_value|
+          assert_equal(attrs[full_name], image_item.send(name))
+          image_item.send("#{name}=", new_value)
+          assert_equal(new_value, image_item.send(name))
+          image_item.send("#{name}=", attrs[full_name])
+          assert_equal(attrs[full_name], image_item.send(name))
+        end
+        
+        [
+          ["width", "image:width", 111],
+          ["image_width", "image:width", 44],
+          ["height", "image:height", 222],
+          ["image_height", "image:height", 88],
+          ["dc_title", "dc:title", "sample-image"],
+        ].each do |name, full_name, new_value|
+          assert_equal(contents[full_name], image_item.send(name))
+          image_item.send("#{name}=", new_value)
+          assert_equal(new_value, image_item.send(name))
+          image_item.send("#{name}=", contents[full_name])
+          assert_equal(contents[full_name], image_item.send(name))
+        end
+      end
+    end
+
+    def test_favicon_to_s
+      favicon = @rss.channel.image_favicon
+      expected = REXML::Document.new(make_element("#{@prefix}:favicon",
+                                                  @favicon_attrs,
+                                                  @favicon_contents))
+      actual = REXML::Document.new(favicon.to_s(false, ""))
+      assert_equal(expected.to_s, actual.to_s)
+    end
+
+    def test_item_to_s
+      @rss.items.each_with_index do |item, i|
+        attrs, contents = @items[i]
+        expected_s = make_element("#{@prefix}:item", attrs, contents)
+        expected = REXML::Document.new(expected_s)
+        actual = REXML::Document.new(item.image_item.to_s(false, ""))
+
+        assert_equal(expected[0].attributes, actual[0].attributes)
+        
+        %w(image:height image:width dc:title).each do |name|
+          actual_target = actual.elements["//#{name}"]
+          expected_target = expected.elements["//#{name}"]
+          assert_equal(expected_target.to_s, actual_target.to_s)
+        end
+      end
+    end
+
+  end
+end

test/rss/test_maker_image.rb

@@ -0,0 +1,62 @@
+require "rss-testcase"
+
+require "rss/maker"
+
+module RSS
+  class TestMakerImage < TestCase
+
+    def setup
+      @uri = "http://web.resource.org/rss/1.0/modules/image/"
+
+      @favicon_infos = {
+        "about" => "http://www.kuro5hin.org/favicon.ico",
+        "image_size" => "small",
+        "dc_title" => "example",
+      }
+      @item_infos = {
+        "about" => "http://www.example.org/item.png",
+        "resource" => "http://www.example.org/item",
+        "dc_title" => "Example Image",
+        "image_width" => 100,
+        "image_height" => 65,
+      }
+    end
+
+    def test_rss10
+      rss = RSS::Maker.make("1.0") do |maker|
+        setup_dummy_channel(maker)
+        @favicon_infos.each do |name, value|
+          maker.channel.image_favicon.__send__("#{name}=", value)
+        end
+
+        setup_dummy_image(maker)
+
+        setup_dummy_item(maker)
+        item = maker.items.last
+        @item_infos.each do |name, value|
+          item.image_item.__send__("#{name}=", value)
+        end
+
+        setup_dummy_textinput(maker)
+      end
+      
+      setup_rss = RSS::Maker.make("1.0") do |maker|
+        rss.setup_maker(maker)
+      end
+
+      [rss, setup_rss].each_with_index do |target, i|
+        favicon = target.channel.image_favicon
+        assert_equal(@favicon_infos["about"], favicon.about)
+        assert_equal(@favicon_infos["image_size"], favicon.image_size)
+        assert_equal(@favicon_infos["dc_title"], favicon.dc_title)
+        
+        item = target.items.last.image_item
+        assert_equal(@item_infos["about"], item.about)
+        assert_equal(@item_infos["resource"], item.resource)
+        assert_equal(@item_infos["image_width"], item.image_width)
+        assert_equal(@item_infos["image_height"], item.image_height)
+        assert_equal(@item_infos["dc_title"], item.dc_title)
+      end
+    end
+  end
+end