タグ別アーカイブ: Tcl

Tcl SQLite build configuration

Prerequisites

Build tool = MinGW GCC v4.9.3
Tcl build path = /c/src/tcl8.6.6/win
Tcl install path = /c/bin/tcl8.6.6
SQLite3 build path = /c/src/sqlite-autoconf-3160200/tea
wxSQLite3 secure source path = /c/src/wxsqlite3-trunk/sqlite3/secure/src

Tcl

./configure --prefix=(Tcl install path)
make
make install

Tk

./configure --prefix=(Tcl install path) --with-tcl=(Tcl build path)
make
make install

TclSQLite

Copy the files in (wxSQLite3 secure source path) to (SQLite3 build path)/generic.
Open tclsqlite3.c and replace "sqlite3.c" by "sqlite3secure.c" in the line #4.
cd (SQLite3 build path)
./configure --enable-threads --prefix=(Tcl install path) --with-tcl=(Tcl build path) CFLAGS="-DSQLITE_HAS_CODEC -DSQLITE_ENABLE_FTS4_UNICODE61"
make
make install

This also works with ActiveTcl.

I could not make sqlite3 v3.8.2 independent from libgcc_s_dw2-1.dll with MinGW gcc v4.8.1.
I don't know the reason. But I could build it with nmake.
For example:
nmake -f makefile.vc TCLDIR=(Tcl install path) INSTALLDIR=(Tcl install path) OPTDEFINES="-DSQLITE_HAS_CODEC"

Ref. 暗号化APIを有効にしたSQLite3のTclバインディングをコンパイルする

Tclでベクトル計算するサンプル

SXGAのリモートデスクトップウィンドウをアスペクト比を保ちつつ65%に縮小し、FullHDのディスプレイの右下に配置したい。手計算でも簡単にできることだが、今まで使ってなかった行列計算ライブラリの練習台に使うことを思いついた。

+-----------------------------+
|                             |
|                             |
|                             |
|                             |
|                             |
|               nw------------+
|               |xxxx         |
|               |   x rec x   |
|               |        xxxx |
|               |           xxx
+---------------+------------se
package require math::linearalgebra
namespace eval LinearAlgebraSample {
  namespace import -force ::math::linearalgebra::*
 
  set scale 0.65
  set v(se) [mkVector 2]
  set v(rec) [mkVector 2]
 
  setelem v(se) 0 0 1920
  setelem v(se) 1 0 1280
 
  setelem v(rec) 0 0 1280
  setelem v(rec) 1 0 1024
 
  set v(nw) [sub_vect $v(se) [scale $scale $v(rec)]]
  show $v(nw)
}

例題がしょぼすぎて練習になってないな。

線形代数苦手でプログラミングにも活用してないし、Maxima、Scilab、Octave、Rとかも使ってない。
ロボットの研究室にいたのに行列計算が苦手というのは勉強してなかった証拠ですね。

Tcl/Tkで任意のフォルダをデフォルトファイラーで開く

たまにやるけど忘れるので。スペースを含まないときは別のやり方でも開くのですが、
一般的には以下のようにします。cmdの引数にエスケープされた状態で渡すというのがキモです。
string mapの変換ルールではエスケープシーケンスが適用されることに注意します。

set office_dir {C:\Program Files\Microsoft Office}
set escaped_office_dir [string map {\\ \\\\} [file nativename $office_dir]]
puts [concat exec [auto_execok start] explorer $escaped_office_dir]
eval exec [auto_execok start] explorer $escaped_office_dir

-- 追記
上記のスクリプトではエクスプローラで開くのが前提だったので、私のように秀丸ファイラーなどの代替ファイラーを使ってる人にとっては100%満足できるものではありませんでした。なんかこれを書いてるちょっと前にStackOverflowに同じ内容の質問が挙がってて、上記の提案をドヤ顔で投稿したところ、100%満足な回答が返ってきました。
http://bit.ly/Uu6q6N

set folderpath "C:/Program Files/Microsoft Office"
exec {*}[auto_execok start] "" [file nativename $folderpath]

ちなみに、趣旨が異なりますが、エクスプローラで指定のファイルを選択した状態でフォルダを開くには、

set out "C:/Program Files (x86)/Microsoft Office/Office14/EXCEL.EXE"
exec explorer.exe /select, [file nativename $out] &

LinkedList in XOTcl

いわゆる双方向連結リストというデータ構造ですが、かつてはリチャードストールマンに、Tclには構造体がないからlinked listを作れないと指摘されていました。今ではいくつもあるオブジェクト指向拡張を使い、クラスを導入すればTclでも他の言語と同じような形で実装できます。

arrayでもできますが、あまり使いやすくならないと思うので、僕はXOTclでLinkedList::ContainerとLinkedList::Elementというクラスを作っていて、これらを継承するか、mixinしたクラスは、連結リストの管理オブジェクト、リスト要素として扱えるようにしています。

通常のリストに比べると、要素が少ないうちは遅いですが、数千数万の要素数になってくるとかなり効率が違ってきます。

テストスクリプト

package require -exact linkedlist 3.0
 
Class ListContainer -instmixin {LinkedList::Container}
Class ListElement -instmixin {LinkedList::Element}
 
proc test_linkedlist {size} {
	set container [ListContainer new]
	for {set i 0} {$i < $size} {incr i} {
		$container push [ListElement new]
	}
	foreach e [$container rlist] {
		$container delete $e
	}
	return {}
}
 
proc test_nativelist {size} {
	set l {}
	for {set i 0} {$i < $size} {incr i} {
		lappend l $i
	}
	for {set i 0} {$i < $size} {incr i} {
		set l [lreplace $l end end]
	}
	return {}
}
 
foreach size {1000 10000 15000 20000 30000} {
	puts "size=$size"
	puts "linkedlist [time {test_linkedlist $size} 2]"
	puts "nativelist [time {test_nativelist $size} 2]"
	puts ""
}

結果

C:\Tcl\lib\linkedlist3>
tclsh test2.tcl
size=1000
linkedlist 30047.5 microseconds per iteration
nativelist 2168.5 microseconds per iteration
 
size=10000
linkedlist 307218.5 microseconds per iteration
nativelist 215719.0 microseconds per iteration
 
size=15000
linkedlist 491008.5 microseconds per iteration
nativelist 469101.5 microseconds per iteration
 
size=20000
linkedlist 627835.0 microseconds per iteration
nativelist 900121.5 microseconds per iteration
 
size=30000
linkedlist 962158.5 microseconds per iteration
nativelist 1995813.5 microseconds per iteration

tktableなんかもarrayをデータソースにすると高速なんですが、arrayを直接操作するよりも、データの順序などを安全に扱うことができる連結リストでデータ管理するのがいいと思います。

package require XOTcl
namespace import xotcl::*
 
namespace eval LinkedList {}
 
Class LinkedList::Container
 
LinkedList::Container instproc init {} {
	my set first {}
	my set last {}
	my set size 0
	next
}
 
LinkedList::Container instproc destroy {} {
	set es [my list]
	foreach e $es {
		my drop $e
	}
	next
	return $es
}
 
LinkedList::Container instproc clear {} {
	set es [my list]
	foreach e $es {
		$e destroy
	}
	return {}
}
 
LinkedList::Container instproc first {} {
	my instvar first
	return $first
}
 
LinkedList::Container instproc last {} {
	my instvar last
	return $last
}
 
LinkedList::Container instproc size {} {
	my instvar size
	return $size
}
 
LinkedList::Container instproc unlink {element} {
	my instvar size first last
 
	if {![Object isobject $element]} {return -1}
	if {[$element container] != [self]} {return -1}
 
	set prev [$element prev_p]
	set next [$element next_p]
 
	$element prev_p {}
	$element next_p {}
	$element container {}
 
	if {$prev eq {}} {
		set first $next
	} else {
		$prev next_p $next
	}
	if {$next eq {}} {
		set last $prev
	} else {
		$next prev_p $prev
	}
 
	incr size -1
}

# private
LinkedList::Container instproc add {element} {
	my instvar size first last
	if {[$element next_p] == $first} {
		set first $element
	}
	if {[$element prev_p] == $last} {
		set last $element
	}
	$element container [self]
	incr size
	return $element
}
 
LinkedList::Container instproc scan {key value} {
	for {set e [my first]} {$e != {}} {set e [$e next_p]} {
		if {[$e $key] == $value} {return $e}
	}
}
 
LinkedList::Container instproc at {index} {
	if {$index == "end"} {return [my last]}
	if {$index < 0 || [my size] <= $index} {return {}}
	set i 0
	for {set e [my first]} {$e != {}} {set e [$e next_p]} {
		if {$i == $index} {return $e}
		incr i
	}
	return {}; # not found
}
 
LinkedList::Container instproc list {} {
	set es {}
	for {set e [my first]} {$e != {}} {set e [$e next_p]} {
		lappend es $e
	}
	return $es
}
 
LinkedList::Container instproc rlist {} {
	set es {}
	for {set e [my last]} {$e != {}} {set e [$e prev_p]} {
		lappend es $e
	}
	return $es
}
 
LinkedList::Container instproc index {element} {
	set i 0
	for {set e [my first]} {$e != {}} {set e [$e next_p]} {
		if {$e == $element} {return $i}
		incr i
	}
	return -1; # not found
}
 
LinkedList::Container instproc pop {} {
	set last [my last]
	my drop $last
}
 
LinkedList::Container instproc push {element} {
	set last [my last]
	if {$last == {}} {
		my add $element
	} else {
		$last append $element
	}
	return $element
}
 
LinkedList::Container instproc shift {} {
	my drop [my first]
}
 
LinkedList::Container instproc unshift {element} {
	set first [my first]
	if {$first == {}} {
		my add $element
	} else {
		$first prepend $element
	}
	return $element
}
 
LinkedList::Container instproc drop {element} {
	if {[my unlink $element] >= 0} {
		return $element
	}
}
 
LinkedList::Container instproc delete {element} {
	if {![Object isobject $element]} {
		$element destroy
	}
}

# InstMixin this class into element class to use container
Class LinkedList::Element -parameter {
	{prev_p {}}
	{next_p {}}
	{container {}}
}
 
LinkedList::Element instproc destroy {} {
	my drop
	next
	return [self]
}
 
LinkedList::Element instproc drop {} {
	if {[my container] != {}} {
		[my container] drop [self]
	}
}
 
LinkedList::Element instproc index {} {
	if {[my container] != {}} {
		[my container] index [self]
	}
}
 
LinkedList::Element instproc append {element} {
	if {[my container] != {}} {
		$element prev_p [self]
		$element next_p [my next_p]
		if {[my next_p] != {}} {
			[my next_p] prev_p $element
		}
		my next_p $element
		[my container] add $element
	}
}
 
LinkedList::Element instproc prepend {element} {
	if {[my container] != {}} {
		$element prev_p [my prev_p]
		$element next_p [self]
		if {[my prev_p] != {}} {
			[my prev_p] next_p $element
		}
		my prev_p $element
		[my container] add $element
	}
}
 
LinkedList::Element instproc status {} {
	append stat "  container = [my container]\n"
	append stat "  index     = [my index]\n"
	append stat "  element   = [self]\n"
	append stat "  neighbors = ([my prev_p]) => ([self]) => ([my next_p])\n"
}
 
package provide linkedlist 3.0

パッケージにしておきました。
linkedlist.3.0.120823

break可能なコードブロック

Tclにはgotoみたいに直列に書いたコードをスキップする制御構文がない。

例えばなんかデータを受信して、チェックしたり加工したりしたあとでどこかに記録するけど、
結果によらず受信回数はカウントしときたい場合、こんなコードを書いたとする。

proc on_receive {data} {
  global cnt
  set res [validate $data]
  if {$res == 1} {
    incr cnt; return $res
  }
  set res [convert $data data2]
  if {$res == 2} {
    incr cnt; return $res
  }
  set res [save $data2]
  incr cnt; return $res
}

incr cnt; return $res; というコードを何度も書かないといけないのが嫌だ。

そこで今まではこんな書き方をしてたことがあった。

proc on_receive {data} {
  global cnt
  while {1} {
    set res [validate $data]
    if {$res == 1} break
    set res [convert $data data2]
    if {$res == 2} break
    set res [save $data2]
    break; # Don't forget!
  }
  incr cnt; return $res
}

ときどきだけど、while {1} の最後のbreakを忘れて、
無限ループに陥ることがあったので、ケアレスミスを減らすため、こう変えた。

proc on_receive {data} {
  global cnt
  foreach once {1} {
    set res [validate $data]
    if {$res == 1} break
    set res [convert $data data2]
    if {$res == 2} break
    set res [save $data2]
  }
  incr cnt; return $res
}

ちなみにforeachのところは、こうしても同じ。

proc on_receive {data} {
  global cnt
  for {} {1} break {
    # ...
  }

だけど何とも見た目が悪い。
初めて見た人は foreach {var1 var2} {1 2} break 並みに分かりづらいだろう。
多重代入のためにlassignが導入されたように、やはり目的が分かる名前の制御構文があったほうがかっこいい。

8.6のtry(8.5ではtcllibに入ってる)を使って、blockという途中でbreak可能な制御構文を作ってみる。

if {[info tclversion] <= 8.5} {
package require try
}
proc block {script} {
  try {
    return [uplevel 1 $script]
  } on break {result options} {}
}

さっきのコードを書き換えてみる。

proc on_receive {data} {
  global cnt
  block {
    set res [validate $data]
    if {$res == 1} break
    set res [convert $data data2]
    if {$res == 2} break
    set res [save $data2]
  }
  incr cnt
  return $res
}

どうかな。

これだけでblockなんて名乗るのはおこがましいので、もうちょい慎ましい名前を考えたら使ってみようと思う。

候補

  • breakable
  • through

Tclだとそんなところに脳のリソースを割かないといけないの?とか言わないでね。

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