Tcl 中没有闭包，但是以字符串为基础的构建使得类似功能的实现并不是一件很困难的事情。在平时的 coding 中倒是经常为一些 Tcl 的规则所困扰。比如说，需要一个用过即丢弃的功能，由于 Tcl 并没有匿名函数一说，为此不得不建立一个命名函数，这个随无伤大雅但在代码的结构上看来却有点扎眼，很让人不爽。

我没有对闭包做深入的研究，所以对于类似闭包功能的使用，仅仅实现了以下的几个功能。第一，一个容易读懂的代码段；第二，具备上下文环境的信息；第三，可在运行时接收参数。

这里所谓容易懂的代码是指不用双引号包围的字符串，虽然使用双引号可以很方便地融入上下文环境中，但是由于转义和执行等情况的存在，不仅不易于编写而且更不容易读明白，因此最好还是用花括号来包围。

第二个问题比较麻烦。对于在花括号中定义的字符串，一般可以使用 subst 来做一些替换工作，但事实上 subst 除了提供延时替换以及 nobackslashes 、 nocommand 控制特征之外，与双引号没有本质上的区别，有些时候甚至不如双引号方便。而即使是用双引号包围了的代码段，依然可能在不经意间造成错误。假设有以下一个程序：

set a jack

set code “ set a mike; puts $a “

在全局环境中，定义了一个值为 jack 的变量 a ；接着，又定义了一个名为 code 的字符串，其中也定义了变量 a ，但是由于存在转义，事实上这个 code 变成了：

set a mike; puts jack

也就是说，如果用 code 来实现闭包的功能，那么将无法在定义与全局中同名的变量。这显然不是很方便，当在类闭包中定义了一个变量的时候，它的作用域应该是属于当前的，而与外层的环境无关，只有没有显式定义的参数我们才需要将其置换为上下文环境中定义的值。

到这里就涉及到一个如何引入上下文环境的问题了，一种就像上面所写的，直接进行变量替换，但是这样做存在副作用；另一种办法是，添加参数定义，即搜索类闭包中的参数，之后在类闭包的开始处添加使用上下文环境的值的定义。还是上面那个例子，使用这个办法， code 将变为：

set a jack

set a mike; puts $a

倘若 code 中没有 a 的显式定义，则是：

set a jack

puts $a

由于添加的定义永远先于类闭包中代码段的内容，所以无论是否定义同名参数，都不会影响到实际的执行效果。这是一种本地优先的规则，类闭包中没有定义的变量将使用全局替换，而定义了的变量，即使是上下文环境同名变量，依然会使用类闭包中定义的值。

显然作为后一种方法，是恰好能满足我们需要的，不过也面临一个问题，即找出在类比包中的变量名。我用了一个正则判断来得到所有的变量，之后进行筛选以剔除重复并使用 info 函数来验证的确存在该变量。

set unique_vars {}

foreach w [regexp -all -inline {\$[:\w]+} $code] {

foreach u $unique_vars {

if {$u == $w} { continue }

}

lappend unique_vars $w

}

set buf {}

foreach w $unique_vars {

    set w [string trimleft $w \$]

    if [uplevel 1 info exists $w] {

        upvar 1 $w var

        set buf "$buf set $w $var;"   

    }

}

最终得到的 buf 将被放置在 code 之前，实现上下文环境对类比包的作用。

第三问题说明，这个类闭包可以接收传入参数，比如一个类闭包被赋值给名为 lambda 的变量，那么它支持形如 ”yield lambda $var” 形式的调用。至于支持传入几个参数，就像 proc 一样，在定义类闭包的时候需要显式说明。

参数传入的实现，在原理上与第二个问题的解决办法类似，但这里的关键在于在与生成的类闭包对象。事实上，该对象包含了两个部分，分别是传入参数的定义和代码段。当执行类闭包的时候，传入的值将和定义的参数结合，被放置于 code 的前端。

最后为了方便使用，我将创建和运行类闭包的命令 fenbie 定义为“ @ ”和“ ~ ”。以下是一个例子：

if 1 {

    set name1 jack

    set name2 mike

    set lamb [ @ {{id 1}} {

        if {$id == {}} {

            puts {nothing to puts}

            return

        }

        while {$id > 0} {

            puts "hello, $name1 and $name2"    

            incr id -1

        }

    } ]

    ~ $lamb

    foreach id {1 2 3} {

        puts "$id time(s):"

        ~ $lamb $id

        puts {}

    }

}

closure包下载

今天，我把前段时间做的一个用于开发 TclTk 的 IDE 工具用 TDK 打了个包，传上来。从做完到修掉大多数 bug ，之间隔了一段时间，一个原因是做完之后精神一下子放松下来了，没有了干劲；第二个，毕竟是一个人的作品，很难做到面面俱到，不过我也算是尽力而为了。目前的作品是可以拿出来用的，至少我自己是用它来写程序的，一面修改一些 bug 。这次打包的程序中，除了对 Tcl 的支持，还有对 python 的语法着色和缩进支持，但只是很简略的，主要还是为了 Tcl 。

接下来，有空的时候，我会再给它增加几个菜单栏，至少要让它有模有样起来。其实一开始我是打算先做菜单的，因为这个我有经验。相反地对于工具栏我没有什么信心，也不知道该放点什么功能上去，于是花了大力气在这方面，最后反而冷落了菜单的设置。我想这个不难，只是要花点功夫。另外，就以前写的一个提词软件，感谢崔姓同学的建议和提供的国外软件样本，有时间我会改写的。

前段时间，我还参与了联汇公司的 link pro 音频工作站测试和部署工作。逻辑功能是比较完善，不过 UI 乱且不说，简直惨不忍睹，国内的软件普遍有这个坏毛病。不过，把管理站建立在 web 中，我个人认为是一个好的方向，以后可以考虑更多一点的富客户端应用，甚至把整个系统都搬到 web 上去，这也不是不可能，而且无论从安全性还是性能、外观都会上一个台阶。不过，就目前的这个管理站的 ASP.Net 开发水平，这些开发员怕还是不够看。

年终将近，铁塔的工程牵扯了我大半的精力，到目前为止竣工已经不再是遥遥无期的事情了，但还需要加把劲争取在年前完成。以前很喜欢听 911 的歌，后来 coldplay ，间或一直在听 sting 的歌，现在变得只能听班得瑞了 … 人啊总是在朝一个方向走的，什么都拉不住 … 下午的天气很好，休息，休息一下 ….

这么做的好处在于可以同时观察到两个相关的代码段，有助于查找需要的信息，或者其中一个编辑另一个执行某个如 tclsh 的命令，等等。差不多就是一个多任务的形式，思维比较活跃的人多是喜欢这样开好几个窗口干活。

这个看似简单易用的玩意儿，实现起来却有点让人无从下手。首先，要让两个同编辑目标的文本框保持同步更新；第二，同一个文本框中切换不同编辑对象时，需要保证如语法渲染之类的操作不影响切换速度；第三，保证分割出来的文本框不会改变父窗体的大小。也许还有别的问题，但这三个是让我有点茫然的东西。

经过一番思量，对于第一个问题，应该可以用 rename 注入代码完成。这在我之前写的文章里有很多涉及，这里就具体不讲。只是需要判断一下两个文本框的编辑对象是否一致。如此一来，对于第二个问题，则需要在每次切换的时候将涉及到渲染或者计算的部分以一定结构的数据形式将结果存储起来以备后用，比如将用于作色渲染的 tag 标记都 dump 出来，还有复制内容，当前插入点等等。

不过，在这里我采用了另一种更加优雅的方式，其实是使用了在 Tk8.5 中新加入的 text 组件命令： peer ，在 actovetcl 的 demo 中也可以看到相关的例子。就是对于一个已建的 text 组件，通过 peer 命令生成它的镜像对象，这两个对象是完全相同的，对任一个的才做都会影响其他对象的变现。事实上，对于一个新建的文本编辑对象，我都首先生成了一个不被 geometry 的 text 对象，用术语说就是 buffer ，再针对这个 buffer 来 peer 出所有需要显示的文本框窗体。那么对于第二个问题，就不是某个 text 组件中内容之间的切换了，而是不同 text 组件之间的切换，可以通过 forget 来完成。这么做的好处在于，我肯本不用考虑切换时状态存储，而且 peer 可以更好地保证编辑对象的一致性要求。

而第三个问题的解决让我对 geometry 中的 place 命令有了全新的认识。众所周知， geometry 的三种方法中，最被广泛使用的是 pack ，其次是 grid ，最后才是 place 。无论那本介绍 Tk 的书籍，都是按照这个顺寻来编写的。也许是应为 pack 的命令最短，也更通俗易懂一些。但在这里，我不得不使用 place 。对于一个需要被分割的文本框，以下的代码很难控制父窗体的大小。

package require Tk

text .t1

text .t2

pack .t1 –fill both –expand 1

pack forget .t1

pack .t1 .t2 -side left –fill both –expand 1

1.close stdout

2.set stdout [open out.txt w]

我关闭并重定义了 stdout ，使其成为某个被打开文件的 channel ，那么执行 puts 事实上是完成了对于文本的写操作。在还有一些情况中，是将 stdout 的结果显示到比如 text 这样的 Tk 组件上，以上的办法显然是无能为力了。作为 stdout 本身必须是一个 channel ，它不能作为一个变量或者其他什么的，所以一个替代的办法是使用 Memchan 模块，以下是在 tcl 的 wiki 上的一段代码。

1.package require Tk

2.package require Memchan

 3.

4.text .t

5..t tag configure stdout -font {Courier 10}

6..t tag configure stderr -font {Courier 10} -foreground red

7.pack .t

 8.

9.# install new stdout

10.close stdout

11.set stdout [fifo]

12.fileevent $stdout readable ".t insert end \[read $stdout\] stdout; .t see end"

13.

14.# install new stderr

15.close stderr

16.set stderr [fifo]

17.fileevent $stderr readable ".t insert end \[read $stderr\] stderr; .t see end"

18.

19.# test it

20.puts "this is stdout"

21.puts stderr "this is stderr"

通过 fileevent ，以上程序提供了一个非常优雅的重定向办法，但是带程序的作者还附加了一句话。事实上，这段代码是无法正确执行的，因为重定义的 stdout 并没有被创建，而且该 bug 似乎至今没有被修复。

warning: the current distribution has a bug, I have submitted a patch to the author

在 cucumber1.1.1 的 tclsh 中需要将 puts 的内容如同 return 的结果一样写入 text 文本组件中，但考虑到循环打印的情况，又不能仅仅将 puts 当做 return 来对待，从而导致执行代码的中止。我的解决办法依然是使用 rename ，在 puts 之前注入代码。

1.con eval {

 2.   rename puts _puts

 3.   proc puts {args} {

 4.       putsstdout $args

 5.   }

6.}

7.interp alias con putsstdout {} putsstdout

8.proc putsstdout {msg} {

 9.   .console insert end "$msg\n"

10.   .console see end

11.}

模拟 tclsh 的过程是发生在名为 con 的子解析器里的，需要使用 alias 将子解析器中的数据交由主解析器中的函数来更新 .console 中的显示。以上代码中的第 4 行便是重定向的关键所在，当然我们还可以将数据以传统形式输出到 stdout 中，这就看具体情况而定了。事实上，这种办法并不算是真正意义上的重定向，但是得到了相同的效果。

1.proc init_region_readonly {text} {

2.    rename $text fake

3.    proc $text {args} {

4.       switch [lindex $args 0] {

5.           "insert" {

6.               if [fake compare insert >= $::com_region_readonly] {

7.                   uplevel 1 fake $args

8.               }

9.           }

10.           "delete" {

11.               if [fake compare insert > $::com_region_readonly] {

12.                   uplevel 1 fake $args

13.               }

14.          }

15.           "default" {

16.               uplevel 1 fake $args

17.           }

18.       }

19.    }

20.}

在写代码的时候，不应该仅仅追求完成某件功能，而是需去寻找一个尽量优雅的方法解决。我不单是这么想，而且也的的确确这么做的。在处理 cucumber 的语法高亮模块时，我思考了很久。最后选择了 rename 办法，即是通过 rename 和重载原命令来得到命令参数，实现代码注入。举个例子：

1.package require Tk

2.text .t

3.pack .t

4.rename .t t

5.proc .t {args} {

6.    # injected code

7.    uplevel #1 t $args

8.}

对于复杂的对象，处于简化使用或者其他的目的，往往会隐藏一些底层的方法，而仅仅提供高级的抽象功能。比如 text 组件的剪切功能，将删除、赋值和标记设定等命令以一定的方式顺序组合在一起，对程序员提供一个指令来完成这一系列的事件。以上的办法为在执行这些底层命令前提供了捕获控制的机会。在高亮的解决方案中，通过这种机制，介入所有的 text 组件指令，筛选出 insert 、 delete 、 mark set 和 see insert 这四个指令，完成当发生包括输入，黏贴、删除，剪切、撤销和重做等事件时的文本高亮渲染。

在这个基本思想的基础上， cucumber1.1.1 版本实现了关键词、变量、注解和引号语句的高亮，但如在实现顺序上有错疏忽，虽然可能不会对破坏的渲染结果，但是会极大影响大文本渲染的效率。为什么单指大文本，因为对于文本输入一般包括键盘输入和大段文本的载入如打开文件或者黏贴。与电脑的处理相比无论打字速度多快，其中的间歇都是足够渲染处理打入的单个符号的上下文环境；而大文本的载入首先是一次操作完成的，与下一个操作之间只有一次间隔，第二需要渲染的内容很多，这么一来渲染效率的瓶颈边出现在大文本处理上了。所以，我所说的效率可以理解为特指大文本渲染效率。在第二个版本里我是使用了以下的一系列优化代码。在这里我首先通过一下函数完成捕获

1.proc _tool_core_fake {cucumber fake} {

2.    set ::$fake [regsub {(.*)\..+$} $cucumber {\1.linumColumn}]

3.    rename $cucumber $fake

4.    eval "proc $cucumber {args} {

5.        after idle \[_tool_core_sortMap $fake \$args\]

6.        uplevel 1 $fake \$args

7.    }"

8.}

_tool_core_fake

第 2 行是设置了一个与当前 text 文本相对应的行号显示组件变量，这里就不再多说了。真正的高亮渲染注入发生在第 5 行，通过以下的函数返回需要执行的指令集。

1.proc _tool_core_sortMap {fake args} {

2.    eval "set args $args"

3.    switch -glob -- $args {

4.        insert* {

5.            set from [$fake index [lindex $args 1]]

6.            set to "$from+[string length [lindex $args 2]]c"

7.            return "

8.            _tool_core_hiContent $fake $from $to;

9.            _tool_incrLinum $fake;

10.            _tool_core_hiLine $fake

11.            "

12.        }

13.        delete* {

14.            set from [$fake index [lindex $args 1]]

15.            return "

16.            _tool_core_hiContent $fake $from $from;

17.            _tool_decrLinum $fake

18.            _tool_core_hiLine $fake

19.            "

20.        }       

21.        {mark set insert*} { return "_tool_core_hiLine $fake" }

22.        {see insert} { return "_tool_core_hiLine $fake" }

23.    }

24.}

_tool_core_sortMap

第二行的作用是消除字符串外的大括号，将如“ {insert end nihao} ”变化为“ insert end nihao ”。之后使用 glob 匹配的 switch 来筛选命令参数。在 1.1.1 版本的筛选函数中，首先我没有加入用于筛选高亮当前行显示的 insert 标记判断，而是在单独的模块中通过绑定事件来完成，这显然是累赘的；第二，最初使用 none 函数来处理非匹配的指令，这个自以为保证代码一致性的手法在事后证明是一个画蛇添足的举动，因为即使是一个空函数，也存在执行消耗，而大量累加执行的结果就是拖慢渲染的速度，这在 1.1.1 中已经被删除了；另外，在处理 insert 和 delete 时，存在值得商榷的渲染级别。在目前代码中可以看见，事实上渲染发生在以上代码的第 8 行和第 16 行里的 _tool_core_hiContent 函数里。顺便提一下，在该函数以下的两个命令，跟行号和当前行指示有关，这里不做详解。

1.proc _tool_core_hiContent {fake from to} {

2.    set temp $from

3.    set temp [_tool_core_hiWord $fake $temp]

4.    while {[$fake compare $temp <= $to]} {

5.        set temp [_tool_core_hiWord $fake $temp]

6.    }

7.    _tool_core_hiQuoteContext $fake

8.    _tool_core_hiCommentContext $fake $from $to

9.}

_tool_core_hiContent

在 _tool_core_hiConetnt 的文本渲染函数中，包含了三个同层次的渲染，分别是处于 index 位于 from 和 to 之间的单词循环渲染和各行注解渲染，以及一次全文引号渲染。这么安排的道理在于，一般情况系关键词和变量都是以单词的形式出现的，可以统一在 _tool_core_hiWord 中处理；注解可能占据一行或者后半行，与其在每次单词渲染时判断是否存在注解起始符，不如在处理完所有的单词之后统一检索当前文本段，前者是单词数量级的运算，而后者是行数量级的运算，显然后者更为高效；引号数量的单双数变化，会造成全文渲染范围的颠倒，但考虑到引号数量与单词相比可能相差两三个数量级，因此这种全文渲染变化是很快速的，尤其是我更引入了延迟渲染的机制，消耗更是可以忽略不计。以下是这三个函数。

1.proc _tool_core_hiWord {fake id} {

2.    if [_tool_ifInWord $fake $id] {

 3.       set head [_tool_indexWordHead $fake $id]

 4.       set end  [_tool_indexWordEnd $fake $id]

 5.       foreach hi {

 6.           _tool_core_hiTextContext

 7.           _tool_core_hiVariableContext

 8.       } { $hi $fake $head $end}

 9.       return "$end +1c"

10.    }

11.    return "$id +1c"

12.}

_tool_core_hiWord

1 ． proc _tool_core_hiCommentContext {fake from to} {

 2.   set f [_tool_linum $fake $from]

 3.   set t [_tool_linum $fake $to]

 4.   while {$f <= $t} {

 5.       $fake tag remove Com "$f.0" "$f.0 lineend"

 6.       if {[$fake search -regexp $::hi_comment_regexp "$f.0" "$f.0 lineend"] != {}} {

 7.           $fake tag add Com [$fake search -regexp $::hi_comment_symbol "$f.0" "$f.0 lineend"] "$f.0 lineend"

 8.       }

 9.       incr f

10.    }

11.}

_tool_core_hiCommentContext

1.proc _tool_core_hiQuoteContext {fake} {

2.    after cancel [list _hiQuoteContext $fake]

3.    after 1000 [list _hiQuoteContext $fake]

4.}

5.proc _hiQuoteContext {fake} {

6.    if {[$fake get 1.0] == "\""} { set rid [list 1.0] } else { set rid {} }

7.    set qid [$fake search -nolinestop -overlap -all -regexp {[^\\]\"} 1.0 end]

8.    foreach id $qid { lappend rid [$fake index [$fake index "$id + 1c"]] }

9.   

10.    if ![set e [llength $rid]] {return}

11.    set now [lindex $rid 0]

12.    $fake tag remove Quo 1.0 $now

13 ．   

14.    set i 1

15.    while {$i < $e} {

16.        set old $now

17.        set now [lindex $rid $i]

18.        if [expr $i % 2] {

19.            $fake tag add Quo $old "$now +1c"

20.        } else {

21.            $fake tag remove Quo "$old +1c" $now

22.        }

23.        incr i

24.    }

25.   

26.    if [expr $e % 2] {

27.        $fake tag add Quo "$now +1c" end

28.    } else {

29.        $fake tag remove Quo "$now +1c" end

30.    }

31.}

_tool_core_hiQuoteContext

所以这次工程的目标就此确定，重写所有函数为可复用，提高渲染速度，重新编写工程架构为可扩展多文档显示，最后添加一个整理代码的工具。目前的渲染部分代码工作基本完成，速度提高了4-5倍，对于小文件基本上做到载入即可渲染完成，80k左右的代码也只需4秒。

Cucumber1.1.1代码下载

缩进基本上就是说在某一块或者上下文环境中的程序代码前添加若干空白，以使得程序结构清晰。就 TclTk 来说，可能需要的一般有三种情况：在花括号中、在方括号中和反斜杠后。对于花括号的判断，我考察了一些编辑器的做法，最偷懒的可能就是查找前一行的缩进位置了，这几乎费不了什么资源和时间，但害处也是显而易见的，倘若前一行缩进发生错误，则之后的都会跟着出错。

一种正确的做法是查询行所在的上下文环境的起始行的缩进，比如 if 或者 while 所处行的缩进。期间我试验了多种方法，最后还是选择了向后的正则查询，这是基于对 TclTk 正则匹配速度的信任所做出的决定。一开始的时候，考虑到大文本的处理性能，我打算为每一行维护信息队列，包括了正反花括号的数量与位置，这样当需要查找当前行所在上下文环境时，只需要对比该位置之前的正反括号数量即可。打个比方：

{{} {}

       {}

你好

}

}

其中各行正反花括号的数量信息如下：

1:  ’{‘ => 3, ‘}’ => 2

2:  ‘{’ => 1, ‘}’ => 1

3:  ‘{’ => 0, ‘}’ => 0

4:  ‘{’ => 0, ‘}’ => 1

5:  ‘{’ => 0, ‘}’ => 0

以上的这种情况中，我们是如何得到你好的缩进位置的呢？首先，“你好“处在第三行，它的上下文环境应考虑第 3 行之前的信息，这里是第 1 、 2 行；令 ’{’ 值为 1 ， ’}’ 值为 -1 ，将第二行相加可得值为 0 ，则继续向上查询；将第一行信息相加得到 1 为正值，即说明第三行所在上下文的起始行即为第一行。

这种方法在即使是巨大的上下文环境时也可以将性能消耗控制在线性范围内，但是维护这么一个信息组也不是一件容易的事情。对于行插入或者删除的情况，都需要对该信息组进行操作，可能需要在 list 中移动上万个单元。幸好 lreplace 的性能及时在百万级的数据下，也表现得不错，应该是够用了。

至于为什么用到之后选择反向正则匹配，是因为我在 text 中拷贝了《 wxPython in action 》的某一章的全部内容并进行了匹配试验，发现速度竟然比使用信息组的性能还要好，而一般的单个程序文件我想不会有这么多字吧。

至于方括号也大致如此，事实上我是用了一个统一的函数来进行处理的。

proc myLeft {id_1 id_2 l r} {

    set id_1 [.f.content search -backward -nolinestop -regexp "\\$l" $id_1 1.0]

    set id_2 [.f.content search -backward -nolinestop -regexp "\\$r" $id_2 1.0]

    if {$id_1 eq {}}  {return {}}

    if {$id_2 eq {}}  {return $id_1}

    if {[.f.content compare $id_1 < $id_2]} {return [myLeft $id_1 $id_2 $l $r]}

    return $id_1

}

以上的函数用来得到第一个正向括号，是 "{" 还是“ [ ”则可以通过复制 l 和 r 参数来决定。基本上这是一个递归，每次比较得到的相向括号的位置前后。

最后的反斜杠的处理，这是最简单的，只需要查询上一行的位置即可，然后缩进 4 个空格。

这个差不多花费了我一周的时间来解决，最后还是因为一件不相关的事情而得到了启发。一般地，我们会考虑将作色绑定在可能使文本内容发生改变的事件上，但是这并不是一件简单的事情，应该说存在着若干个截然不同的情况。比如说，删除动作之后，我们应该考虑当前插入点的前后文本的变化；而在拷贝事件时，需要考虑被插入文本的前后端以及本身的内容，但如果之前有范围选择存在，则还需要首先考虑选择区域应被删除。总之这是一件很复杂的事情，很难保证代码的清晰易懂，也很有可能随之带来 bug ，因此这个思路被暂时搁置了。

在确定 <modified> 事件是发生在文本发生改变之后，我试图寻找一个简洁的办法来得到事件前后的文本差异，但是似乎只能寄希望于极耗时间的全文比对，这种着色引擎只适用于大文本的载入情况，而对于实时渲染显然非常低效。

考虑再三，我还是选择了绑定各个事件的办法，但编写调试的过程相当痛苦，充满了复杂的逻辑和奇怪的问题。这个时间里，群里有人大约是在讨论关于 rename 的必要性，我记忆里隐约记得是有这么一个看似毫无价值的命令的存在。随手 google 了一下权作放松，可恰恰是这次搜索使得高亮的进展柳暗花明。

在 tcltk 的 wiki 上，有一篇关于在 text 中通过 rename 的办法得到实际操作指令的的例子。具体的讲，比如一个 copy ，可能会被分解为选择，删除和插入等几个步骤，通过 rename 我们可以在具体的指令操作发生之前捕捉到它。对于高亮而言，事实上需要关心的只是文本的变化，也就是说我只要能够捕捉到插入和删除这两个基本事件就可以了。

这个技巧很诡异：

text .t

pack .t

rename .t fake

proc .t {args} {

    puts "catch: $args"

uplevel #1 fake $args

}

“ rename ”应该是会注销掉“ .t ”的命令，但由于 tk 本身的命名规则，“ .t ”依然会被使用到，因此我们必须将其重新定义为一个接收参数的过程，在该过程中使用“ fake ”来真正执行指令，显然在此之前我们已经捕获了它。需要注意的是，别在真正执行指令之后插入别的代码，因为该过程在最后会对全局带来一些必要的副作用，不能将其覆盖。因此，诸如着色的操作代码必须写在真正指令之前。

这算是一个矛盾的事情，着色代码放在了引发着色事件的前面，这岂不是在当前操作未来的内容。幸好还有“ after idle ”，用来缓冲代码的命令。纵观整个程序，充满了“ after idle ”，实在是非同小可的东西。

热替换的好处就不提了，至少是有用处的。如果没有 Erlang ，我想迟早也会去关注这个话题。尤其是在 Tk 中绑定事件处理函数时或者在调试的时候，根据不同的需要，可以动态的改变代码功能，这显然非常方便。但是如果实现的过程本身可能破坏原来代码的结构，我想这就有点得不偿失了。最起码的，应该有一套方便并且可遵循的规则。下面就两种办法进行分析。

先来设定一个最基本的实验环境：一个用来显示结果的文本框和一个用来激发事件的按钮，足矣。需要达到的目的是，在运行过程中，动态改变按钮的绑定处理函数。

第一种做法 -- 嵌入 source ：

Tcl 的代码集成，包括 package 等，多是建立在 source 和 load 的基础上的，说白了 package require 不过也是在 pkgIndex.tcl 中找到相应的文件并 source 之。所以第一种思路是在按钮的绑定函数中 source 文件，主要的代码片段如下：

text .t

button .bt -text test -command {

    source b.tcl

}

pack .t .bt

我不得不将 source 放在函数中的原因在于，必须在每次运行时检测文件，以确保运行了最新修改过的代码。其中， b.tcl 的代码为

.t insetr end “1\n”

用来在文本框中新插入一行，内容为 1 。如果将 1 改为 2 ，程序将自动变换为插入内容为 2 的一行。但是这里有两个问题存在，首先这种检测很多时候是多余的，我们并不需要修改代码；第二， source 本身是对文件的读入操作，这不可避免地引入了 IO ，也就是说影像了性能。这种热替换方式，不大适合与巨大的事件处理函数，或者可能遭遇频繁调用的情况。

第二种做法 –- socket 指令 :

在修改完 b.tcl 之后，需要有人告诉运行程序一声，“喂，你的按钮该换代码了！”，接着主程序兴冲冲地去找按钮处理函数的源代码。这里讲的其实是一个进程间通信的问题，于是选择了 socket 。我把这个过程写了两个文件，一个是名为 hot.tm 的包，提供了两个主要函数： init ，用来指定可以被替换的函数及其相对应的文件； update ，用来具体实施热替换。其实替换的过程也是一个 source ，不同之处在于 source 的内容是一个函数，而非第一种情况里函数中的一段代码，这样新的函数将覆盖之前的版本。这是 a.tcl 的代码需要有所修改：

lappend auto_path [file dirname [info script]]

package require hot

hot::init b b.tcl

text .t

button .bt -text test –command b

pack .t .bt

在 hot 的 namespace 中，维护着一个函数名到源文件的 array ，在初始化时需要指明哪些函数是可以被热替换的。我可不想随便哪个函数都可以被替换，这就乱套了。

另一个文件时 hotc.tcl ，用来在修改完代码之后通知运行程序来进行热替换，当然这个过程只能依靠人工来完成了。比如在这里需要替换 b 函数，那么就执行一下 hotc.tcl b 。

最后我想，这应该是一个比较可以被接受的方法了。其实即使是标榜着热替换的 erlang ，也需要在修改代码之后 compile 的，这就好比执行了 hotc.tcl ，只不过 erlang 的做法是语言级的。

代码下载

在前面一贴关于 linum 的杂论中，我使用了双 text 的拼接来实现 linum ，关于其优点主要在于只读属性的设置。但在涉及到纵向的 scrollbar 时，我们不得不面对一个问题：如何使 linum 和文本内容跟随 scrollbar 一齐滚动？

一般而言， scrollbar 是绑定与一个可 scroll 组件的，比如 text 或者 list 。显然，没有相应的 scrollcommand 命令的组件，例如容器组件就不属于可 scroll 组件，也就无法绑定到 scrollbar 的。因此，我们不能使用 frame 作为一个统一的外部包裹来绑定 scrollbar 。 canvas 是很好的替换选择，但有鉴于 canvas 过于强大，除非需要实现特定效果，我个人不倾向于使用这种大型组件。另外，要提一下的经验是，对于单组件绑定 scrollbar ，最好是使用 widget::scrolledwindow ，它带 optional 特征，只有在必要的时候才会显示 scrollbar 本身。

办法终归是有的，但是需要首先知道 scrollbar 到底是怎么工作的。从实际出发，我们会在两种大的情况下触发到滚动事件，第一个是直接操作 scrollbar ；第二个是操作文本内容，包括插入和光标上下移动。

对于第一种情况，比如我们点击 scrollbar 中的下标时，首先发生的并非是改变滑条的位置，相反的文本框的内容整体下移了一行，此时出发了文本框的滚屏事件，而在该事件相关的处理程序再设置 scrollbar 的滑条到相应的位置。也就是说，对于 scrollbar 的操作，最终还是要落实到 text 上来完成的。而相对与第二种情况， scrollbar 其实只是指定了文本框的滚屏形式，例如点击下标是下滚一行，点击滑条上方的空白条是上滚一页，拖动则是滚屏一定数值。在第二种情况中，滚屏完全由 text 自身控制，比如绑定一个滚屏到文本开头的快捷键，则 scrollbar 也将相应地滑动到最上端。

text 的 command 以及 scrollbar 的 x(y)scrollcommand 命令是很需要注意的，它们其实是被其他过程用来产生命令的参数，并不直接执行。在 ttk::scrollbar 中有如下一段定义：

proc ttk::scrollbar::Scroll {w n units} {

    set cmd [$w cget -command]

    if {$cmd ne ""} {

uplevel #0 $cmd scroll $n $units

    }

}

显然“ $w cget -command ”得到的比如“ .txt yview ”与之后参数结合，最后真正执行的是“ .txt yview scroll 1 unit ”这样的命令。这么做其实是限制了对 scrollbar 的操作，由于实际的使用是一个很死板的命令，除非修改 scrollbar 的定义或者使用 snit 重新构造一个，不然除了“ $w yview ”和“ $w xview ”，我们不可能得到任何有益的副作用。

text 的 command 相对好一点，它为绑定的函数添加了两个参数，分别表示可视区域的最上端和最下端处于全文的相对位置。事实上这么做是提供了编写规范，即为了设置滑块的位置，在绑定函数中一定要有 scrollbar 的 set 命令。除此之外总还是有一些自由的，双 text 滚动的 hack 就在此处进入。

当文本组件发生滚屏事件时，一方面需要设置滑条位置，另外再引发 linum 产生滚屏，如此便打到了双滚屏的效果，这里改变的无非是一个先来后到的顺序问题，要实现多组件滚动的话也是一个道理。

要设置滑条位置需要的是自动传入的两个参数，而 linum 滚屏用到的则是其中的第一个参数。命令如下：

.scrollbar set $first $last

.linum yview moveto $first

关于 text 这个组件，说起来简单，其实却是又相当复杂，今天我从一个带 linum 的 text 出发，管中窥豹，以期抛砖引玉。

使用 emacs 的大多会安装行号显示，便于 debug 时的定位，比较常用的便是 linum.el 。这里的 linum 是 line number 的意思。现在我们来实现这种效果，以达到当发生输入、粘贴、删除或者退格事件时，左侧行号自动匹配实际文本行数。

首先需要设置行号的显示方式，这是最基础但却是很重要的一个决定。倘若是在单 text 组件中使用 tag 实现 linum ，那么有两个问题。第一，无法保证 linum 的只读状态；第二，复制时会包含行号，大多数情况下这是多余的。这里我选择了两个组件的粘合，事实上是将两个 text 拼在一起，当然也可以使用 entry 或者 canvas ，只是前者比较方便，容易保持代码的一致性。在此之前，最好设置一个用于记录最后行号值的变量 linum ，初始化为 1 。

package require Tk

set linum 1

frame .f

text .f.linum -width 1 -bg gray -bd 0

.f.linum insert end "1"

.f.linum configure -state disable

text .f.content -bd 0

pack .f.linum -side left -expand 1 -fill y

pack .f.content -side left -expand 1 -fill both

pack .f

我们得到了如下图片显示的记事本，当然目前它还不能正常添加或删除行号，需要定义并绑定一系列过程。另外，随着行号的增加，应该相应设置左侧灰带的宽度来正常显示行号。

无论是因为何种文本编辑操作使得文本行数发生改变，在改变行号之前，我们都必须得到文本行的数量。这里有几种办法，比如 count 或者 index ，我们使用后者，顺便对 index 进行介绍。

proc linum {w} {

    return [expr int([$w index "end - 1c"])]

}

此处的 index 是“ end – 1c ”，表示文本的最后的前一个位置。事实上，这就是文本的实际最后位置，只不过因为 end 被定义为“ the character just after the last newline ”，一个不存在字符，所以必须在 end 的位置处再向前减去一个 character ，可以简写为“ - 1c ”。同样的，如果要得到待插入行的最后一个字符的位置，应使用“ insert lineend ”；向前一个字符就是“ insert lineend – 1c ”，如此类推。

现在要切实做一些绑定了，一般地我们使用回车和退格来进行换行，其中回车是必然转换为一个换行符的，而退格则在遇到换行符时才会通过一系列的操作实现换行。还是应该提一下，通过 ascii 码我们可以看到回车并不是换行，换行的码值是 10 ，而回车是 13 ，所以需要转换；而退格换行的行为，在实际中行数并不会立即发生变化，在退格时先增加一个退格符，再将该退格符连同上一个换行符一起删除。需要注意的是，文本永远在其最后保留一个换行符。

明白了这个细节，接下来的事情就好办了。由于我们还需要响应长按的情况，所以必须绑定是 KeyPress 过程，但无论是 KeyPress 还是 KeyRelease ，当遇到换行时 text 都会在之后做做一些以上描述的小手脚，所以真正的绑定处理过程必须发生在这些小手脚完成之后。这是一个矛盾，但并非不可调和。

after idle incrLinum

在绑定中，使用“ after idle ”的小技巧便可以轻松应对。它让 text 先干完想干的，一旦空下来就立即执行真正的处理过程。

除了回车和退格，还应该增加对一些常用的比如粘贴或删除操作的支持。对于粘贴，通常的快捷键是“ ctrl v ”，对应的事件是“ <Control-Key-v> ”，当然也可以是如 emacs 中的“ ctrl y ”。使用以下的形式可以方便地增加对事件的支持。

foreach keysum {

    <KeyPress-Return>

    <Control-Key-v>

} {

    bind .f.content $keysum {

after idle incrLinum

    }

}

点击下载代码。 另外，添加比如语法着色也并非难事，只是肯定会相当复杂，以后再说了。

关于 Button 最诡异的事情大概就是与变量作用域相关的命令了。 Button 事件是作用域全局域下而非任何过程函数中。如果 Button 是在一个过程函数中创建的，那么该 Button 的命令之后将在不同的作用域中执行。即使是使用 binding 的事件处理，也将在全局域中执行。

我认为这是一个关于定义与执行的时间问题。举例来说，当定义一个 Button 时可以使用到一组变量，但在使用该 Button 的时候却用的是另一组变量。当遇到混合上下文环境的情况，这就变得很混乱了。以下例子中的 Button 命令使用到了两个变量： x 和 val 。其中 x 是在执行中需要使用的全局变量，，本地变量 val 在定义 Button 时使用。

proc Trouble {args} {

   set b 0

   # Display the value of x, a global variable

   label .label -textvariable x

   set f [frame .buttons -borderwidth 10]

   # Create buttons that multiply x by their value

   foreach val $args {

      button $f.$b -text $val \

         -command "set x \[expr \$x * $val\]"

      pack $f.$b -side left

      incr b

   }

   pack .label $f

}

set x 1

Trouble -1 4 7 36

这个例子用了一个 label 来设置 textvariable 属性来显示 x 的当前值，该 x 总是一个全局变量。在这里，因为 x 不在 Trouble 中使用（只是被定义），所以不用使用 global 来说明 x 是全局变量（当然，用了也没关系）。 Button 命令之后则将在全局范围被使用。

但是这个 Button 命令的定义非常丑陋，在 foreach 中的定义的 Button 使用了本地的变量 val ，而其他变量的实值替换将发生在之后的全局范围内。因此需要前缀反斜杠使 $x 和 expr 不在双引号被转义。

set x \[expr \$x * $val\]

我们举个反例来说，以下的这里例子中给 x 在定义过程中被直接赋值了一个常量，因而无法达到上面例子中的目的，显然是不正确的。

button $f.$b -text $val -command "set x [expr $x * $val]"

另外一个不正确的做法是对整个命令使用花括号（就是 “” ）。这么做则是过犹不及了，所有的变量都将在全局范围内执行时被实值替换，这个时候 tcl 解析器可能发生提示发生错误，说找不到某些变量。

界面处理还是延用了 bugd 的组件，为了方便修改，这次在 lib 文件夹里直接使用了 tcl 文件，而不是以往用到的 tbc 。总之，这一系列的程序应该都是 foobar-like 的。音频处理方面使用了 snack ，也有人用 lame 的，但是 lame 没有专门的模块，需要 dll 来调用，因此不是很方便，就更别提文档了。在 http://www.speech.kth.se/snack/ 中有详细的文档和例子，很容易上手。另外，也可以参考 snackAmp 的源代码。在功能上，和我的设想有类似之处，比如说除了普通的播放之外，还可以作为网络服务器，提供在线广播收听。

OK ，要做到这步显然是需要花大功夫的，目前先作为一个正常的播放器来解决。但恰恰使这个“正常”让我花费了好大功夫。故障的表现是这样的，当使用 snack 播放音乐时，无论是最小化、最大化 snack 程序还是其他的任何桌面窗体，播放都会卡一下。但是，当我使用 snackAmp 来播放的时候却不会有这个现象，而它也是调用 snack 的。

起初，我的想法是可能 snackAmp 中的 snack 版本和我使用的不一样，于是做了替换，结果依旧。之后，我怀疑是因为 snack 的原始 Tk 界面占用资源，于是将它 withdraw 了，也没有作用。没办法之下，研究起 snackAmp 的源代码起来。话说回来，这个程序写得真是糟糕，虽然分成了几十个 package ，但是相关性太高，到了你中有我我中有你的境界 , 绝大多数根本无法重用，看起来也云里雾里。最后终于定位到了 macro 中的 Play 和 soundCtrol 中的 play 两个函数，仔细分析之下发现真正涉及到播放的部分竟然非常普通，没有特别之处。打印出来的 snack::sound 对象属性基本雷同。

事实上，我忽略了最重要也是最有效的工具，文档。当发给 snack 和 snackAmp 作者的 email 石沉大海数日之后，我万念俱灰，却偶尔发现了在 manual 关于 snack ：： audio 的 playLatency 介绍中有一句“ A low value makes new sound samples reach the loudspeakers quickly at the risk of gaps in the output stream ”。不会是它吧！连忙对比了默认状态下和 snackAmp 中的 playLantency 参数，一个 250 ，一个 2000 ， 8 倍！就是这个！问题迎刃而解。

点击下载 （刚修订了一些bug，甚至连逻辑也改了，所以下面的内容也就没什么意义，要源代码的可电邮我gyn_tadao@yahoo.com.cn，要运行下载代码请先安装TCL解析器http://www.activestate.com/activetcl/downloads/）因为对

之前，我使用 perl 来写了一个，之后思索着索性写一个 sqlite 的 schedule 工具吧，最好还是带 GUI 的。这并不难， bugd 中的组件正好可以利用。说干就干，两天的功夫就完成了。跟 bugd 很像，算是一个派生物了吧，但是复杂度小了很多，一则实现的功能比较单一，不需要复杂的界面配套；二来，不是 CS 的结构，考虑的问题都集中在本地。真正的难点是怎么维护一个对各个事件需要发生的时间的判断，同时又可以方便地增加和删除 schedule 事件。在这里，我维护了 一个名为 rl 的队列，意思是 runing-list ，将需要进入 schedule 的事件名称放入到该队列中，要停止的时候再将其从该队列中移除，由专门的函数循环处理该队列。

该函数叫 runSchedule ，形式如下。其中的 yet 用于判断是否已经在当天检查了时间队列 rl 。

proc runSchedule {} {

    global rl loop_interval yet

    update idletask

    if [at 00:00:00] {

       if $yet {

           schedule $rl

           set yet 0

       }

    }

    after [expr $loop_interval * 1000] runSchedule

}

在原来的函数中，我是使用 after idle 来进行循环的，由于使用了 update idletasks ，该程序界面运行第很流畅，但是在资源管理器中 cpu 的使用率达到了 100% ，没办法是能改为一个秒级的 interval 。

每个新的一天到来的时候，真正的队列处理在 schedule 被处理。该函数如下：

proc schedule {rl} {

    global cmd scdl dbl

    set sep1 @

    set sep2 |

    foreach n $rl {

       set m [dict get $cmd $n]

       set s [dict get $scdl $n]

       set d [dict get $dbl $n]

       foreach {ery dy tm} [split $s $sep1] {}

       switch $ery {

           month {    set d [clock format [clock seconds] -format "%d"]}

           week  {set d [clock format [clock seconds] -format "%a"]}

           default {}

       }

       if [info exists d] {

           foreach e [split $dy $sep2] {

              if {$e eq $d} {

                  runCommand $tm $d $m

              }

           }

        } else {

           runCommand $tm $m

       }  

    }

}

在 schedule 中，根据 rl 中的事件名称，将通过 cmd 、 scdl 和 dbl 三个 dict ，调出对应的命令，运行时间和所在的数据库。之后通过 runCommand 来根据具体时间来运行 SQL 命令。

proc runCommand {tm db cmd} {

    global loop_interval

    if ![at $tm] {

       update idletask

       after [expr $loop_interval * 1000] [list runCommand $tm $cmd]

    } else {

       sqlite3 d $db

       if [catch {d eval $cmd} err] {

           updateStatusInfo [join $err _]

       }

       d close

    }

}

最后需要说明的是 at 函数，它是用来判断是否过了所给定的时间的，也就是说只要当前时间大于输入参数，它就返回为真，不然为否。所以真正意义上应该叫做 after ，但是 after 已经是 tcl 默认函数了，所以改成了 at 。

proc at {tm} {

    global yet

    if {[clock scan $tm] >= [clock seconds]} {set yet 1; return 1}

    return 0

}

之后，对 status 处于 outdated 的 item 的 background 着色以明显突出，但是为了尽量不影像其他代码，在原先的 addItem 之外又包了一个叫 judgeAddItem 的函数，用于判断 item 状态，从而给与新定义了橘黄颜色的 style 。

bugd 无论使界面还是内部功能的设计，大约是完成了一半了。今天完成了几个对条目状态进行判断和提示的函数，另外由于数据库是 sqlite 的，所以不得不写一个件事程序用于事务管理，来保证数据的更新。感觉这种 CS 形式的程序，最好还是不要用这种没有自带网络服务的数据库，实在是很麻烦。虽然现在用得还好，我是打算换成 pgsql 了。还好是用 DBI 写的，只需要修改一个数据库连接就行了。在数据库方面， dump 一下应该没问题，我用的数据类型还是比较普通的。

其实很容易想到的一个办法是维护一个堆栈，一旦有新的 toplevel 出现，就被压入堆栈，销毁的时候在 pop 出来。我们不需要为此修改每一个 toplevel 的构造函数，只需要建立 <Map> 和 <Destroy> 的事件句柄。举个例子如下：

bind Toplevel <Map>   {_tPush %W}

bind Toplevel <Destroy> {_tPop  %W}

proc _tPush {w} {

    global top_stack

    if {[lindex $top_stack 0] ne $w} {

       set top_stack [linsert $top_stack 0 $w]

    }

}

proc _tPop {w} {

    global top_stack

    if {[lindex $top_stack 0] eq $w} {

       set top_stack [lreplace $top_stack 0 0]

    }

}

。

在还没有意识到重复性之前，我是一个接着一个地写这些代码的，最后弄得程序巨大而拖沓。因此想做一个抽象，来分离显示界面的逻辑与数据的分离，从而达到仅通过修改数据即可得到预期界面的效果。

首先，需要一个方便可用的 geometry manager ，可以考虑 pack 和 grid 。使用 pack ，除非设置好组件的宽度，不然很难对齐，但不同的组件对于宽度的单位也各不相同，会给抽象增加复杂性，所以在这种明显需要对齐的情况中，我个人比较倾向与使用 grid 。

接着，组件的数据表示要简洁而必要且一目了然，在这点上我花了点功夫，最后还是套用了在 bugd 中用于 C/S 间传递数据的格式。

proc frameData {} {

    # widget:state:width:pathname:text

    return {

    {label:::unl:username entry:readonly:40:une: label::3:veriunl:}

    {label:::pwdl:password entry::40:pwde:}

    {{checkbutton:::chkadmin:if admin?} {}}

    }

}

用 4 个“ : ”来作为分隔符（当然也可以用其他的）的一串信息，对应上面的注解。为了达到扩展的目的，使用空串来说明该位子由前一个可用组件来占据。

在处理到用户管理列表的时候，我还是新建了一个 toplevel ，原打算是要抽象用户自管理程序的，但是似乎有点麻烦，留着以后再做了。其中用到了借个 checkbotton ，是 ttk 版的。从文档里可以看出 ttk 的 checkbutton 省略了不少选项和命令，但反观原生的，也存在诸多不便。首先，它没有直接取得被选择状态数值的命令，只有一个 variable 选项，所以状态的操作必须围绕这个 variable ；第二，还是和这个 variable 有关，挡在过程中生成 checkbutton 而 variable 是非 global 的时候，显示出来的 checkbutton 是无法看出是否被 toggle 的，而反过来一旦被 toggle 上，这个 variable 就自动变成 global 的了。为了不必要的麻烦 , 我的解决办法是，在要使用到 checkbutton 的过程中直接设置 global 变量供 checkbutton 设为 variable ，当包含该 checkbutton 的 toplevel 销毁时一道 destroy 掉 global 变量。

最近一直在写一个文件传阅系统，其中涉及到一个包含显示文件状态的text的notebook。虽然和本文无关，但还是要说一下的是，text最好指定一个height，不然在fill和expand之后，会在notebook中占据显示空间，我在这里用到的数值是7。还有的是，在布局notebook时可以考虑使用panedwindow，它可以缩放组件占据面积的大小。

言归正传，tooltip是用来为比如像工具栏中的按钮提供动态提示的组件。查看源代码，我们可以看到，被bind的Tooltip不是具体关于tooltip本身的，通过bindtag它被添加到需要被显示信息的组件的事件处理队列中。一旦比如Enter或者Leave事件发生，将运行tooltip中相应的函数。

具体用于显示信息的路径名为.__tooltip__的toplevel中只有一个label，有时候我们需要增加一些显示信息，比如图片之类的时候，就显得很不够。我们可以通过在.__tooltip__中增加一个canvas或者text来实现。对于原存在的label，我建议最多做一些configure，将其的anchor、bd、bg分别设为w、0、#ffffff，它便如个title一样，不会对显示效果产生太大影响。

但是还是存在一些局限，例如同时存在需要显示原状和增加了现实效果这两种tip时，上面的这种办法就无能为力了，因为.__tooltip__是被共享的，修改就意味着所有需要显示tip的组件都将为此使用新的风格。所以，可以确定的是，我们需要有两种显示状态。解决的办法按照深度可分为三种：第一种，在原先的.__tooltip__中针对不同的组件来withdrawn新增的效果，这需要做出一些判断，甚至在构造函数中增加一个选项；第二，在tooltip的hash变量G中除了TOPLEVEL之外，再增加一个例如TOPLEVEL_2这样的key值，也就是说再造一个专门用于显示特殊效果的组件，当然判断还是需要的；第三种也是最简单的一种，重建一个用来显示特殊效果tip的package，说起来好像很难，其实只是替换tooltip和Tooltip这两个关键词即可。

用   TclTk   重写了视频录制程序，其中有些细节不便在前一篇《   Perl   程序转换为   Tcl/Tk   实例一则》中细述，因为它主要是讲用两种语言来实现的差别。另外，后来我又对程序做了一些修改，所以不得不再费力写下来了。  

首先对于在   Tk   中使用到的命令，因为循环的关系，我们不需要将它放置在   Tk   界面代码之前。但是如果在循环之外使用，那么就只能在用到什么之前，就定义什么。这是一个细节，还是要注意一下，免得调试的时候手忙脚乱。  

最主要提到的有两方面，其一是关于如何正确关闭管道。如果只是简单地   close   掉管道，除非子进程会自动关闭，不然可能一直运行下去。比如：  

catch {open "|ping 127.0.0.1 -t"} output

close $output

（使用   catch   来捕捉错误，阻止烦人的错误提示）  

打开任务管理器，你会看见   ping   进程依然在执行，因此这并没有达到彻底关闭的效果，这在   Perl   里也是一样的。需要显示地将进程关闭掉，我们可以使用一下的命令：  

catch {exec taskkill /F /PID [pid $pipe]}

在这里，调用了系统命令   taskkill   来关闭进程，   pid   的作用是返回一个管道子进程的   pid   值，如果没有该进程将返回一个错误，并被外围的   catch   捕获。  

另外的一个是关于如何输出的问题，我们使用  

gets $pipe line

来得到管道的输出，之后通过一定的过滤，最终显示到   Text   上，我用两种结尾的输出试验了一下。用“   \r   ”的时候，   cpu   使用率一度达到   100%   ，最终程序僵死，甚至连子进程都无法正常退出。用“   \n   ”则恢复正常了，   cpu   使用率很低，亦不会出现阻塞。另外，为了不输出空行，做了一些必要的检测：  

set line [string trim $line]

if [string compare $line {}] {

   $log insert end [string trim $line]\n

   $log see end

}

每种语言都有其擅长和不足的地方，在某项工作甚至工作的某一部分中选择合适的语言往往可以达到事半功倍的效果。所以，多掌握一些知识是很有必要的，当然了也可以用一些大语言，比如说 C 或者 Java ，它们几乎是可以通吃一切问题的，但是付出的代价一样高昂，一些可以用几行 Perl 或者 Python 实现的功能，换作 Java 可能需要花费几倍的工作量，所以这里就不谈了。

在很久以前，为了方便工作人员录制电视节目，我用 Perl 写了一个基于 Tk 的设置界面。界面如下图：

大致上就是设置一个时间，然后在该时间点自动启动一个录制程序。当时由于时间仓促，本着够用就好的精神，很快就写好了，所以难免留下一些 bug 。比如说设置完之后，没有将按钮重置为退出。这还是小事，最主要的还是一旦录制程序启动，整个界面就被阻塞，这是 windows 下 Perl 的老毛病了，几乎无药可救。

其实即便如此，这个程序还是可以顺利使用的，但是作为一个解决长时间运算阻塞界面的办法，将它移植到 Tcl 上，还是有一些意义的。在上一篇随笔中，我大致讲到了 filevent 和 select 在 windows 下的差别，正好可以在这里验证一下，同时通过移植的过程，也可以更清楚地了解和区分两种语言在某些功能上的不同实现办法。最终实现的工具如下图 ：

这里将代码拆分开来进行分析。

首先是界面部分，这一部分其实是最简单的，所以在实现上几乎一样，只不过是语法上的差别而已。有一点值得注意的是 Tcl 中是不需要的 mainloop 这样的命令来显式地启动主循环。

第二，因为定时启动需要计算启动时间与当前事件的差值，所以需要处理一些时间相关的参数。 Perl 中可以使用 localtime 来得到年份、月、日和秒等共 9 个值，供组合使用。在 Tcl 中，有一个 clock 命令，通过 format 可以实现类似的功能，感觉上 Tcl 的更方便一些。相同的感觉也处理时间差值时也存在，因为 Perl 中需要拆分一个某种形式的时间表达式，提取必要参数给 timelocal 计算总秒数，而 Tcl 的 clock 有 scan 可以直接生成。

第三，在像 Perl 的 BrowseEntry 和 Tcl 的 ComboBox 的下拉框中，经常会插入一串连续的数字。 Perl 可以使用形如“（ 1..10 ）”来表示 1-10 这 10 个数字，但是在 Tcl 里没有类似的命令，所以当遇到大数组表达式的时候，最好是写一个方法来模拟 Perl 中的这种功能。

第四，为了确保录制任务在制定的时间点启动，需要有检查是否超时。在 Tcl 里这个实现因为有 after 变得很轻松，只要指定一个需要等待时间戳， Tcl 就会在过晚这段时间之后启动需要执行的指令，而 Perl 就麻烦多了。在 Tk 的 mainloop 中，使用 repeat(1000, sub {…}) 使其每隔一秒钟执行一次检查，看是否超时。一旦检查到超时则停止检查并启动录制；若没有则提示继续下次检查。

第五，在如何启动录制这点上，两者使用了不同的手段。 Tcl 使用管道来启动进程，使得自身不被阻塞（不过在使用producer的时候还是会阻塞，用ping就没问题，这个很奇怪），并且使用 filevent 监测打开句柄的状态。而 Perl 因为不可靠的 select ，我们只能使用 system ，通过阻塞的办法来获知任务是否完成，这也是一个无可奈何的事情了。

（代码下载）

因为在用  Perl-Tk  或者  Socket  时，经常会需要监视某些打开的句柄而不至于阻塞主循环， 对于这些 win32  下的 Perl 表现远不如 Linux 下来得得心应手，但这时候我基本没有什么办法。这和 windows 的底层 select 实现有关，而 Perl 恰恰是调用它的，但我一直认为肯定有别的替代办法，因为 Tcl/Tk 的 fileevent 就表现得很好。

下面是一个例子，用来显示  ping  的结果。这里有两个组件，一个是按钮，用来开始和停止  ping  ；另一个是  text  用来显示  ping  的结果。分别用  Perl  和  Tcl/Tk  代码来实现，看看他们有什么不同。

use Tk;

$count = 4;

$host = '127.0.01';

$mw = MainWindow->new;

$bt = $mw->Button(-text => 'Clink to start ping', -command => \&RunPing);

$bt->pack(-fill => 'x');

$tx = $mw->Text(-width => 50, -height => 30);

$tx->pack;

MainLoop;

sub RunPing {

   open $fd, "ping -n $count $host|";

   $mw->fileevent($fd, 'readable' => sub {

      sysread $fd, $buf, 30;

      $tx->insert('end', $buf);

      });

   $bt->configure(-text => 'close', -command => \&ClosePing);

}

sub ClosePing {

   close $fd;

   undef $fd;

   $bt->configure(-text => 'Clink to start ping', -command => \&RunPing);

}

运行的结果很让人失望，在  readable  的事件中加入  print  后而已更清楚地看到，事实上  readable  事件是没有被触发过的。这里的  fileevent  是  Tk  中处理事件触发的函数，它为句柄的两个状态（  readable  ，  writable  ）设定触发函数，其本质上使用了系统的  select  或者  poll  ，换句话说即便是用  Perl  的  select  或者  IO::Seelct  也是于事无补。文档里的原话佐证了这点“  A file is considered to be readable on same basis as the system's select() (or poll()).  ”。

所以可以这么讲，  win32  下的  Perl  是不大适合处理事件响应的，因而也就很难处理好处理网络相关或者界面需要运行后台长时间操作的情况。接下来换作是使用  Tcl/Tk  来实现这一功能，值得一提的是在  Perl  下  50  宽度的  button  和  text  是不等长的，所以索性在  pack  里用  fill  自动拓宽了，而在  Tcl/Tk  中没有这个问题。

package require Tk

set pingcount 4

set host {127.0.0.1}

button .btn -text {Clink to start ping} -command "RunPing $host $pingcount" -width 50

text .text -width 50 -height 30

pack .btn .text

proc RunPing {host count} {

   set fd [open "|ping -n $count $host"]

   ;#fconfigure $fd -blocking 0

   fileevent $fd readable "onPingRead $fd $count $host"

   .btn configure -text "close" -command "closeFd $fd $count $host"

}

proc onPingRead {fd count host} {

   if {[eof $fd]} {

      closeFd $fd $count $host

   } else {

      set buf [gets $fd]

      .text insert {end} "$buf\n"

   }

}

proc closeFd {fd count host} {

   close $fd

   .btn configure -text {Clink to start ping} -command "RunPing $host $count"

}

为了使用同样条件的管道，屏蔽了设置非阻塞的代码行，但这么作   因为系统不得不等待管道中的进程运行结束，所以   也使得  close  没有起到应有的作用。

运行的结果很令人满意，  test  没有被阻塞，在显示  ping  结果的同时，依然可以在  text  中执行输入，而且  button  也可以被顺利按下。这么看来  Tcl/Tk  比之  Perl  在  win32  下，显然在事件处理上占有优势，而且这个占优的方面是极其重要的。