カテゴリー別アーカイブ: Tcl/Tk

XOTcl というか Next Scripting Framework 2.0b3のコンパイル

XOTclの最新安定版はteacupで配布してる1.6.7ですが、今のところTcl8.6b2で使うことができません。
私の場合、XOTclに依存しまくってるので、8.4から8.6に1つ飛ばしで移行しようと思ったところ、これだけが引っかかっていて、
仕方なく8.5に移行しました。

一方XOTcl開発チームの人々はNext Scripting Framework (NSF)という壮大なプロジェクトを立ち上げ、XOTclの次期バージョンである2.0はそのフレームワークの上で実装されているそうです。すでにNSF Beta2のソースコードが配布されているのでコンパイルしてみました。

MinGWで比較的簡単にコンパイルできました。
Tcl関連のソースコードでVC6で簡単にコンパイルできるものってあんまりないです。

必要なもの
C:/src/tcl8.6b2 --- Tclのソースコード。tcl86b2-src.zip
C:/src/nsf2.0b3 --- NSFのソースコード。nsf2.0b3.tar.gz

MinGW shellを起動し、

cd /c/src/nsf2.0b3
./configure --prefix=/c/bin/tcl8. 6b2/lib --exec-prefix=/c/tcl8.6b2 --enable-threads
make
make install

簡単なスクリプトは動くようです。

(bin) 1 % package require XOTcl
2.0b3
(bin) 2 % namespace import xotcl::*
(bin) 3 % Class Dog
::Dog
(bin) 4 % Dog instproc init {} {puts "created"}
::nsf::classes::Dog::init
(bin) 5 % Dog instproc hello {} {puts "Bow"}
::nsf::classes::Dog::hello
(bin) 6 % set dog [Dog new]
created
::nsf::__#0
(bin) 7 % $dog hello
Bow
(bin) 8 % info patchlevel
8.6b

が、いろんな機能を使ってる複雑なコードの場合はエラーが出ました。以下例。
Warning: Arguments 'component xdobry::sqlite' to constructor of object ::idemeta are most likely not processed
no current object; command called outside the context of a Next Scripting method

XOTcl 1と2の非互換性についてはドキュメントがありますが、
Incompatibilities between XOTcl 1 and XOTcl 2

これで全部網羅してるとは思えないし、
2で追加されたというcurrentというコマンドは存在しないと言われます。

せっかく作ったので丸ごと置いときます。
Tcl/Tk8.6b2 with nsf2.0b3

ipconfigを呼ばないでMACアドレスのリストを取得する(twapi 3.1.17対応ほか)

「ipconfigを呼ばないでMACアドレスのリストを取得する」を書いた時点のtwapiのバージョンはたしか3.0.32だったんじゃないかと思いますが、3.0.32の次のバージョン3.1.17が去年の暮に出ていました。出てるのは知ってたんですが、8.4サポート廃止ということで使ってはいませんでした。

SourceForge.com twapi 3.1.17

最近新しいPCを手に入れて、8.6や8.5を試していたのですが、get_netif_info -typeの仕様が変わって、今までのように文字列でなく数値が返ってくるようになっていたので、一応3.0.xとの互換性も考慮した修正をしておきました。
あと、前のスクリプトでは有線LANしか取得してませんでしたが、無線LANインターフェースのMACアドレスも取得できるようにしておきました。

proc getPhysicalAddresses {} {
	set macs {}
	foreach i [twapi::get_netif_indices] {
		set opt_type [twapi::get_netif_info $i -type]
		if {$opt_type eq {}} {
			continue
		}
		foreach {opt type} $opt_type break
		if {($type != 6 && $type ne "ethernet") && ($type != 71 && $type ne "other")} {
			continue
		}
		set opt_physicaladdress [twapi::get_netif_info $i -physicaladdress]
		if {$opt_physicaladdress eq {}} {
			continue
		}
		foreach {opt physicaladdress} $opt_physicaladdress break
		lappend macs [string toupper $physicaladdress]
	}
	return $macs
}

それから、ケーブルが抜かれてるインターフェースに関してはtwapi::get_netif_indicesで情報取得できません。
以下のスクリプトを使えば可能になります。

proc twapi::get_netif_indices {} {
	set size [twapi::get_netif_count]
	set indices {}
	set cnt 0
	set idx 1
	for {set cnt 0} {$cnt < $size} {} {
		if {![catch {twapi::get_netif_info $idx -adapterindex} opt_adapterindex]} {
			if {$opt_adapterindex ne {}} {
				foreach {opt adapterindex} $opt_adapterindex break
				if {$adapterindex == $idx} {
					lappend indices $idx
				}
			}
			incr cnt
		}
		incr idx
	}
	return $indices
}

いったい何の役に立つのかは内緒です。とにかくMACアドレスリストを取得したいんだというひとが他にいれば役立ててくれれば幸いです。

TkSQLite Tcl script function

こんなに便利な機能があったのに使ってなかったなんて。

TkSQLite Tcl script function

こういうスクリプトを書いておいて、TkSQLiteの初期設定->SQLiteのタブに登録しておくと、

# unixepoch.tcl
proc UnixEpoch {t} {
	clock format $t -format "%Y-%m-%d %H:%M:%S"
}
db function unixepoch UnixEpoch
SELECT datetime(executed_at, 'unixepoch', 'localtime'), * FROM history; -- これが
SELECT unixepoch(executed_at),* FROM history; -- こんな風にかけるよ。

Tcl array関係のお役立ち関数2つ

Cでは定数を定義するのに#defineを使うことが多いようですが、
Tclではプリプロセッサがないので、同じ方法は使えません。

グローバル変数を使うというのが最初に思い浮かぶと思うんですが、
switch文の分岐に変数を使うには特殊な方法が必要なことなどを考えるといろいろと
不都合なことが多いんですよ(すごくやっつけな説明です)。

いろいろ試した結果、双方向に参照できるディクショナリ用意する方法が一番しっくりきました。

以下のプロシージャを使うと、順方向のarrayを定義した後、一発で逆方向のarrayを定義することができるので便利です。

# usage: invert_array ARY ARY_INV
# ARY's values should be unique.
proc invert_array {_in _out} {
	upvar $_in in
	upvar $_out out
 
	array set out {}
	array unset out *
 
	foreach {key val} [array get in] {
		set out($val) $key
	}
}

おまけですが、Tclには標準でparrayというプロシージャあって、array全体を見やすく表示してくれるんですが、
標準出力にしか出してくれません。parrayは組み込みコマンドではなく、プロシージャなので、中身を見れば簡単に拡張できます。

  1. parray ARY; # オリジナルのparray互換
  2. parray stdout ARY; # 標準出力を明示
  3. parray $ch ARY; # 任意のチャネルを指定

以下、2,3のような拡張を施したparrayです。

# usage: parray ARY
# Equivalent to original parray except that you can optionally specify output channel as a first argument.
proc parray {args} {
	switch [llength $args] {
	1 {
		set ch stdout
		set a [lindex $args 0]
		set pattern *
	}
	2 {
		set ch [lindex $args 0]
		if {[file channels $ch] ne $ch} {
			set ch stdout
			foreach {a pattern} $args break
		} else {
			foreach {ch a} $args break
			set pattern *
		}
	}
	3 {
		foreach {ch a pattern} $args break
	}
	default {
		error "wrong # args: should be \"parray ?channelId? a ?pattern?\""
	}
	}
	upvar 1 $a array
	if {![array exists array]} {
		error "\"$a\" isn't an array"
	}
	set maxl 0
	foreach name [array names array $pattern] {
		if {[string length $name] > $maxl} {
			set maxl [string length $name]
		}
	}
	set maxl [expr {$maxl + [string length $a] + 2}]
	foreach name [lsort -dictionary [array names array $pattern]] {
		set nameString [format %s(%s) $a $name]
		puts $ch [format "%-*s = %s" $maxl $nameString $array($name)]
	}
}

FfidlでC言語のエクスポート関数に配列のポインタを渡して内容を書き換えてもらう

なぜかFfidlで配列を引数に渡すサンプルがどこにも見当たらなかったので、作ってみました。

C言語のDLL側のサンプル。
関数pow2は任意の大きさの整数型配列とそのサイズを受け取り、
その配列の各要素を2乗した値に置き換えるものです。

/* pow2.c */
__declspec(dllexport) void pow2(int* out, int sz)
{
    int i;
    for(i = 0; i < sz; i++)
    {
        out[i] = out[i] * out[i];
    }
}

Visual Studioコンソールから以下を実行してコンパイルする。

cl /LD pow2.c

pow2.dllができるので、pow2をTclから実行してみる。

package require Ffidl
ffidl::callout pow2 {pointer-var int} int [ffidl::symbol pow2.dll pow2]
 
set int_ary {1 2 3 4 5}
set len [llength $int_ary]
set b_ary [binary format i$len $int_ary]
pow2 b_ary $len
 
binary scan $b_ary i$len out_ary
puts $out_ary
#=> 1 4 9 16 25

int_aryの中身が書き換わるわけじゃないです。
int_aryをもとにバイナリ文字列を作り、そのポインタを関数に渡して書き換えてもらいます。
書き換わったバイナリ文字列をスキャンして新しいTclのリストout_aryを得ます。
aryって書いてるけどリストですのであしからず。

DLLの作成で参考にしたページ:
http://marigold.sakura.ne.jp/devel/windows/dll/windll.html

似たようなことしようとしてそうな人:
http://stackoverflow.com/q/5595918/323107

[Tcl/Tk] Tkウィンドウ上でマウスポインタの下の色を取得する

Tcler's Wikiには以下のページで2通りの方法が紹介されています。

http://wiki.tcl.tk/15339

1つ目はキャンバスアイテムがimageの場合は、中身の画像に対してgetコマンドを使用してピクセルのRGB値を取得し、それ以外のアイテムに対してはitemcget -fillの値を取得するという方法で、2つ目はウィンドウのキャプチャを取得して、それに対してgetコマンドを発行する方法になっています。

が、いずれもいまいちでした。
まず、1つ目の方法ではimage以外の図形のフチの色が取得できません。
2つ目の方法はめちゃくちゃ遅いので実用的ではありません。

以下を参考にして、GDIを使う方法にしました。

http://www.csharp411.com/c-getpixel-and-setpixel/

この方法だと別にcanvasに限らず色が取得できます。

ただし、Windows専用になります。Tkのウィンドウの外に出るとマウスの動きをキャプチャできなくなるので一般的なカラーピッカーみたいなのを作りたければ、そこのところを作りこむ必要があります。

本当はそこまでやりたかったけど、TclでWM_MOUSEMOVEメッセージを処理する方法が分からないので保留。

SetPixelはおまけです。
Ffidlはこちらからダウンロードできます。

package require Tk
package require Ffidl
 
namespace eval Win32 {
	variable HWND_DESKTOP 0
	ffidl::callout GetDC {pointer} pointer [ffidl::symbol user32.dll GetDC]
	ffidl::callout ReleaseDC {pointer pointer} int [ffidl::symbol user32.dll ReleaseDC]
}
namespace eval Gdi32 {
	ffidl::callout GetPixel {pointer int int} int [ffidl::symbol gdi32.dll GetPixel]
	ffidl::callout SetPixel {pointer int int int} int [ffidl::symbol gdi32.dll SetPixel]
}
 
proc GetPixel {hdc x y} {
	set c [Gdi32::GetPixel $hdc $x $y]
 
	set R [expr {($c & 0x000000FF)}]
	set G [expr {($c & 0x0000FF00) >>  8}]
	set B [expr {($c & 0x00FF0000) >> 16}]
 
	return [list $R $G $B]
}
 
proc SetPixel {hdc x y r g b} {
	set c [expr {(int($r & 0x00FF0000) >> 16)
	           | (int($g & 0x0000FF00))
	           | (int($b & 0x000000FF) << 16)
	}]
 
	Gdi32::SetPixel $hdc $x $y $c
}

# demo
set c [canvas .c]
pack $c
 
$c create text  55  95  -text "ABC"     -fill white
$c create rect 125  25  145  45         -fill red
$c create oval  25 125   45 145         -fill green
$c create line  15 100   70 125         -fill blue
$c create poly 100  65  130  65 100  20 -fill cyan -outline black
 
bind $c <Motion> {
	set x [winfo pointerx .]
	set y [winfo pointery .]
 
	set hdc [Win32::GetDC $::Win32::HWND_DESKTOP]
	foreach {R G B} [GetPixel $hdc $x $y] break
	Win32::ReleaseDC $::Win32::HWND_DESKTOP $hdc
 
	wm title . "(x, y) = ($x, $y) : ($R, $G, $B)"
}
console show

コマンドライン版Everythingを使ってSubversionのワーキングコピーフォルダをリストアップする

最近TortoiseSVNが1.7になって、既存のワーキングコピーを初めて操作するときに自動的に管理ファイルをアップデートするらしい既存のワーキングコピーを手動でアップデートする必要があるらしい ( WC-NG )。未アップデートのワーキングコピーが混在するのは気持ち悪いのでまとめてアップデートしたいと思う。

しかし、僕の場合、ワーキングコピーがいろんなところに散在していて探すのがめんどくさい。それでワーキングコピーのルートフォルダをリストアップするコマンドラインアプリを作りました。

また、複数のプロジェクトをメンテしていてコミットがおろそかになってしまうことが多いんですが、これで列挙すればどこにワーキングセットがあるのか分かりやすくなります。

各ドライブ以下を全検索するのはやってられないので、Everythingの力を借りています。
そのためNTFSフォーマットのドライブ限定になります。

# This script searches all subversion working copy root folders.
# You need Tcl interpreter and Everything command line interface (es.exe).
# Download from this site: http://www.voidtools.com/download.php
# tclsh FindSvnRoots.tcl
array set wcopy {}
set ch [open {|es -i -s -r "^.svn$"}]
 
while {![eof $ch]} {
	if {[gets $ch path] != -1} {
		set parent [file dirname $path]
		set wcopy($parent) 1
	}
}
 
set paths [lsort -dictionary [array names wcopy]]
foreach path $paths {
	array unset wcopy "${path}?*"
}
 
set paths [lsort -dictionary [array names wcopy]]
foreach path $paths {
	puts $path
}

ここからes.exeをダウンロードして、スクリプトの実行フォルダかパスの通ったフォルダに置く必要があります。
http://www.voidtools.com/download.php

※ Tclインタープリタ不要なバージョンも作りました。
これにもes.exeは必要です。

FindSvnRoots 1.0.0.0 (Windows binary)

# 未コミットかどうかも表示できるようにしたい。

2011-10-27 追記

svn status -qコマンドで取得した状態で、" "でないものがあった場合は最初に見つけたものを表示します。

>FindSvnRoots.exe
  C:\src\my\project1
M C:\src\my\project2
A C:\src\my\project2

svnコマンドにパスが通っていない場合は全ての状態が" "になります。

>FindSvnRoots.exe
  C:\src\my\project1
  C:\src\my\project2

FindSvnRoots 2.0.0.0 (Windows binary)

ソースコードは以下。

# This script searches all subversion working copy root folders.
# You need Everything command line interface (es.exe).
# tclsh FindSvnRoots.tcl
# Output format:
# [ ACDIMRX?!~] "Working set folder's full path"
 
set svn_exists [expr {![catch {exec svn --version --quiet}]}]
 
array set wcopy {}
 
set ch [open {|es -i -s -r "^.svn$"}]
 
while {![eof $ch]} {
	if {[gets $ch path] != -1} {
		set parent [file dirname $path]
		set wcopy($parent) 1
	}
}
 
set paths [lsort -dictionary [array names wcopy]]
foreach path $paths {
	array unset wcopy "${path}?*"
}
 
set paths [lsort -dictionary [array names wcopy]]
foreach path $paths {
	set native_path [file nativename $path]
	set s " "
	if {$svn_exists} {
		if {[catch {exec svn status -q $path} str]} {
			puts "E $path : Failed to retrieve local modification : [lindex [split $str \n] 0]"
		}
		set lines [split $str \n]
		foreach line $lines {
			set s [string index $line 0]
			if {$s ne " "} {
				break
			}
		}
	}
	puts "$s $native_path"
}

[Tcl] How to know decimal representation of binary float

I wrote experimental script to convert binary float to decimal.

References:
http://www.h-schmidt.net/FloatApplet/IEEE754.html

http://sandbox.mc.edu/~bennet/cs110/flt/ftod.html

set exponent 00000001
set mantissa 10001001001101110100110
 
binary scan [binary format B* $exponent] c exponent
set exponent [expr {$exponent - 127}]
 
if {$exponent <= -127} {
	set mantissa "$mantissa"
} else {
	set mantissa "1$mantissa"
}
 
set i 0
set sum 0.0
foreach b [split $mantissa {}] {
	set sum [expr {$sum + pow(2,$exponent-$i)*$b}]
	incr i
}
puts $sum
#=> 1.80555933856e-038

[Tcl] gets or read - which is faster

Usually, I use "gets" to read a text file.
But I tried "read" to know which is really faster.

proc test_gets {f} {
	set ch [open [format {|nkf -s "%s"} $f]]
	while {![eof $ch]} {
	    if {[gets $ch line] != -1} {
	        puts $line
	    }
	}
	close $ch
}
 
proc test_read {f} {
	set ch [open [format {|nkf -s "%s"} $f]]
	set txt [read $ch]
	close $ch
	set lines [split $txt \n]
	foreach line $lines {
	    puts $line
	}
}
 
set filename [file join [pwd] "hoge.txt"]
set bench1 [time {test_gets $filename} 10]
set bench2 [time {test_read $filename} 10]
 
puts $bench1
puts $bench2

# 1162 bytes
# gets => 39963 microseconds per iteration
# read => 27447 microseconds per iteration

# 10350085 bytes
# gets => 6420444 microseconds per iteration
# read => 6246802 microseconds per iteration

If you read the whole text, "read" is a little faster.
But if you stop reading in the middle of the content, "gets" is more efficient.

"read" uses more memory as the file size increases.

Though "read" is a little bit faster in some situation,
I think "gets" is more efficient in most cases.

Decoding IEEE754 Single Precision Floating Point Number in Tcl - NaN, Infinite etc.

Each version of Tcl recognizes big-endian IEEE754 encoded exceptional single precision floating point numbers like followings.

# IEEE754 Reference
# http://babbage.cs.qc.edu/courses/cs341/IEEE-754references.html
namespace eval IEEE754 {
	variable CONST {
		Quiet-NaN_MIN            FFFFFFFF
		Quiet-NaN_MAX            FFC00001
		Indeterminate            FFC00000
		Signaling-NaN_MIN        FFBFFFFF
		Signaling-NaN_MAX        FF800001
		-Infinity                FF800000
		NegativeNormalized_MIN   FF7FFFFF
		NegativeNormalized_MAX   80800000
		NegativeDenormalized_MIN 807FFFFF
		NegativeDenormalized_MAX 80000001
		-0                       80000000
		+0                       00000000
		PositiveDenormalized_MIN 00000001
		PositiveDenormalized_MAX 007FFFFF
		PositiveNormalized_MIN   00800000
		PositiveNormalized_MAX   7F7FFFFF
		Infinity                 7F800000
		Signaling+NaN_MIN        7F800001
		Signaling+NaN_MAX        7FBFFFFF
		Quiet+NaN_MIN            7FC00000
		Quiet+NaN_MAX            7FFFFFFF
	}
}
 
if {$::tcl_version >= 8.5} {
	proc IEEE754::string_reverse {s} {
		string reverse $s
	}
} else {
	package require struct::list
	package require textutil
	proc IEEE754::string_reverse {s} {
		join [struct::list reverse [textutil::splitn $s 1]] ""
	}
}
 
proc IEEE754::test {} {
	variable CONST
	puts "tcl_patchLevel = $::tcl_patchLevel"
	foreach {name hex} $CONST {
		set name [format %-24s $name]
		binary scan [string_reverse [binary format H* $hex]] f a
		puts "FLOAT: $name $a"
	}
}
 
IEEE754::test

# tcl_patchLevel = 8.4.19
# FLOAT: Quiet-NaN_MIN            -1.#QNAN
# FLOAT: Quiet-NaN_MAX            -1.#QNAN
# FLOAT: Indeterminate            -1.#IND
# FLOAT: Signaling-NaN_MIN        -1.#QNAN
# FLOAT: Signaling-NaN_MAX        -1.#QNAN
# FLOAT: -Infinity                -1.#INF
# FLOAT: NegativeNormalized_MIN   -3.40282346639e+038
# FLOAT: NegativeNormalized_MAX   -1.17549435082e-038
# FLOAT: NegativeDenormalized_MIN -1.17549421069e-038
# FLOAT: NegativeDenormalized_MAX -1.40129846432e-045
# FLOAT: -0                       -0.0
# FLOAT: +0                       0.0
# FLOAT: PositiveDenormalized_MIN 1.40129846432e-045
# FLOAT: PositiveDenormalized_MAX 1.17549421069e-038
# FLOAT: PositiveNormalized_MIN   1.17549435082e-038
# FLOAT: PositiveNormalized_MAX   3.40282346639e+038
# FLOAT: Infinity                 1.#INF
# FLOAT: Signaling+NaN_MIN        1.#QNAN
# FLOAT: Signaling+NaN_MAX        1.#QNAN
# FLOAT: Quiet+NaN_MIN            1.#QNAN
# FLOAT: Quiet+NaN_MAX            1.#QNAN

# tcl_patchLevel = 8.5.9
# FLOAT: Quiet-NaN_MIN            -NaN(7ffffe0000000)
# FLOAT: Quiet-NaN_MAX            -NaN(20000000)
# FLOAT: Indeterminate            -NaN
# FLOAT: Signaling-NaN_MIN        -NaN(7ffffe0000000)
# FLOAT: Signaling-NaN_MAX        -NaN(20000000)
# FLOAT: -Infinity                -Inf
# FLOAT: NegativeNormalized_MIN   -3.4028234663852886e+38
# FLOAT: NegativeNormalized_MAX   -1.1754943508222875e-38
# FLOAT: NegativeDenormalized_MIN -1.1754942106924411e-38
# FLOAT: NegativeDenormalized_MAX -1.401298464324817e-45
# FLOAT: -0                       -0.0
# FLOAT: +0                       0.0
# FLOAT: PositiveDenormalized_MIN 1.401298464324817e-45
# FLOAT: PositiveDenormalized_MAX 1.1754942106924411e-38
# FLOAT: PositiveNormalized_MIN   1.1754943508222875e-38
# FLOAT: PositiveNormalized_MAX   3.4028234663852886e+38
# FLOAT: Infinity                 Inf
# FLOAT: Signaling+NaN_MIN        NaN(20000000)
# FLOAT: Signaling+NaN_MAX        NaN(7ffffe0000000)
# FLOAT: Quiet+NaN_MIN            NaN
# FLOAT: Quiet+NaN_MAX            NaN(7ffffe0000000)

# tcl_patchLevel = 8.6b1.2
# FLOAT: Quiet-NaN_MIN            -NaN(7ffffe0000000)
# FLOAT: Quiet-NaN_MAX            -NaN(20000000)
# FLOAT: Indeterminate            -NaN
# FLOAT: Signaling-NaN_MIN        -NaN(7ffffe0000000)
# FLOAT: Signaling-NaN_MAX        -NaN(20000000)
# FLOAT: -Infinity                -Inf
# FLOAT: NegativeNormalized_MIN   -3.4028234663852886e+38
# FLOAT: NegativeNormalized_MAX   -1.1754943508222875e-38
# FLOAT: NegativeDenormalized_MIN -1.1754942106924411e-38
# FLOAT: NegativeDenormalized_MAX -1.401298464324817e-45
# FLOAT: -0                       -0.0
# FLOAT: +0                       0.0
# FLOAT: PositiveDenormalized_MIN 1.401298464324817e-45
# FLOAT: PositiveDenormalized_MAX 1.1754942106924411e-38
# FLOAT: PositiveNormalized_MIN   1.1754943508222875e-38
# FLOAT: PositiveNormalized_MAX   3.4028234663852886e+38
# FLOAT: Infinity                 Inf
# FLOAT: Signaling+NaN_MIN        NaN(20000000)
# FLOAT: Signaling+NaN_MAX        NaN(7ffffe0000000)
# FLOAT: Quiet+NaN_MIN            NaN
# FLOAT: Quiet+NaN_MAX            NaN(7ffffe0000000)