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だとそんなところに脳のリソースを割かないといけないの?とか言わないでね。

ソースコード中のUnicodeリテラルを展開して出力

Tclスクリプトにマルチバイト文字が入ってると、環境によっては文字化けして実行できないという問題がありました。
コメントは英語表記にしてあるのでいいとして、ギリシャ文字のシグマとか、パスワード隠し記号とかは見た目上どうしても使いたいので、そういう記号は全部Unicodeリテラル表記にしました。ここのツールを使うと簡単にUnicodeリテラルを調べられます。

http://www.snible.org/java2/uni2java.html

ついでに、あとでリテラルが何の記号に対応するかみたいという場合もあると思って、以下のようなスクリプトを書きました。
これでリテラルを展開した結果を見られます。

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
}

仕組みとしては単に\uXXXXという文字を見つけて、置換してるだけです。
Tclの場合は、Unicodeは16bitまでしか定義されてないので、リテラル表記は例外なくこれで処理できるようです。
なお、{\uXXXX}という表記はリテラルとはみなされないのですが、ここでは考慮してません。

Jet/ACEでExcelファイルをCSVに変換する

ある分析装置がxlsx形式でレポート出力するのでExcelのCOMインターフェース経由でCSVに落としてから処理していました。
この方法だとMicrosoft Excelが必須になってしまいます。
あとExcel本体経由なので、セキュリティ設定によっては手動でロック解除しないと開けないとかいう場合もあります。
そこでライセンス料をケチるべく、Excelなしでxls/xlsx -> CSV変換プログラムを書く方法を調べました。

# filename: subst_unicode_literal.tcl
proc read_file {f} {
	set ch [open $f r]
	set out [read $ch]
	close $ch
	return $out
}
 
proc extract_unicode_literals {str _ll _lu} {
	upvar $_ll ll
	upvar $_lu lu
	set ll [lsort -unique [regexp -all -inline -expanded {(\\u[0-9A-Fa-f]{4})} $str]]
	set lu [subst [join $ll]]
}
 
proc make_map {ll lu} {
	set map {}
	foreach l $ll u $lu {
		lappend map $l $u
	}
	return $map
}
 
set f [lindex $argv 0]
set str [read_file $f]
 
set ll {}
set lu {}
extract_unicode_literals $str ll lu
set map [make_map $ll $lu]
set out [string map $map $str]
 
puts -nonewline $out

コンパイルは、

csc Excel2CSV.cs

ファイル名を引数に与えると、標準出力にCSVを出力します。エラーは終了コードで通知します。

Excel2CSV.exe sample.xlsx > sample.xlsx.csv
echo %ERRORLEVEL%
0

必須コンポーネント

Microsoft Access Database Engine 2010 Redistributable

.NET Framework 2.0 以上?

.NET Framework 4.0向けに コンパイルしたもの Excel2CSV

ただ、COM経由で取得したCSVとは、数値の値が違うことがあります。
原因はDAOを使った場合は、表示書式を適用した後の値しか取得できないためのようです。
たとえば、12345.6789という数値を持つセルに、"小数以下桁数2桁、桁区切り"という書式が設定されている場合、12,345.68が抽出されます。
考え方によってはこの方がいいというケースも、だめなケースもあるかも知れません。
とりあえず、桁区切り(,)の書式はCSVにとって邪魔なので、上記のプログラムでは数値とみなせる文字列は一旦数値に変換しています。

ちなみにxdoc2txtの場合は、桁区切りなし、四捨五入済みの数値を吐きます。
というか、いろいろ実験してたらxdoc2txtの出力ってゴミが入ってたりしてプログラムから後処理するのがめんどくさげ。
そもそも商用ライセンスは1000本単位じゃないと買えないので却下。

あと、xlsxをxlsに変換してExcel2CSVにかけると、可視シートだけが出力されるという微妙な違いもありました。
普通は隠しシートの内容を見たいということはないと思いますが。

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を起動し、

// filename: Excel2CSV.cs
using System;
using System.Data;
using System.Data.OleDb;
using System.IO;
 
namespace Excel2CSV
{
    public class Excel2CSV
    {
        const int SUCCESS = 0;
        const int MISSING_FILE_ERROR = 1;
        const int FILE_EXTENSION_ERROR = 2;
        public static int Main(string[] args)
        {
            string path = args[0];
            var finfo = new FileInfo(path);
            if (!finfo.Exists)
            {
                return MISSING_FILE_ERROR;
            }
            string connectionString;
            switch (finfo.Extension.ToLower())
            {
                case ".xls":
                    connectionString = String.Format("Provider=Microsoft.Jet.OLEDB.4.0;Data Source={0};Extended Properties=\"Excel 8.0;HDR=NO;IMEX=1;TypeGuessRows=0;\"", path);
                    break;
                case ".xlsx":
                    connectionString = String.Format("Provider=Microsoft.ACE.OLEDB.12.0;Data Source={0};Extended Properties=\"Excel 12.0 Xml;HDR=NO;IMEX=1;\"", path);
                    break;
                default:
                    return FILE_EXTENSION_ERROR;
            }
 
            OleDbConnection oleConn = new OleDbConnection(connectionString);
            OleDbCommand oleCmd = new OleDbCommand();
            OleDbDataReader oleReader;
 
            oleConn.Open();
            oleCmd.Connection = oleConn;
 
            DataTable tables = oleConn.GetSchema("Tables");
            foreach (DataRow row in tables.Rows)
            {
                string sheetName = row["TABLE_NAME"].ToString();
                string sheetText = "";
                try
                {
                    sheetText += String.Format("[{0}]", sheetName) + Environment.NewLine;
                    oleCmd.CommandText = "SELECT * FROM [" + sheetName + "]";
                    oleReader = oleCmd.ExecuteReader();
                    while (oleReader.Read())
                    {
                        int fieldCount = oleReader.FieldCount;
                        string[] line = new string[fieldCount];
                        for (int i = 0; i < fieldCount; i++)
                        {
                            string val = oleReader[i].ToString();
                            double dval;
                            if (double.TryParse(val, out dval))
                            {
                                line[i] = dval.ToString(); // 12,345.67みたいな数字を12345.67に変換。
                            }
                            else
                            {
                                line[i] = val;
                            }
                        }
                        sheetText += String.Join(",", line) + Environment.NewLine;
                    }
                    oleReader.Close();
                    Console.WriteLine(sheetText);
                }
                catch
                {
                }
            }
            oleConn.Close();
            oleCmd.Dispose();
            oleConn.Dispose();
            return SUCCESS;
        }
    }
}

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

csc Excel2CSV.cs

が、いろんな機能を使ってる複雑なコードの場合はエラーが出ました。以下例。
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アドレスも取得できるようにしておきました。

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

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

(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

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

TkSQLite Tcl script function

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

TkSQLite Tcl script function

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

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
}
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
}

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

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

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

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

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

# unixepoch.tcl
proc UnixEpoch {t} {
	clock format $t -format "%Y-%m-%d %H:%M:%S"
}
db function unixepoch UnixEpoch

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

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

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

SELECT datetime(executed_at, 'unixepoch', 'localtime'), * FROM history; -- これが
SELECT unixepoch(executed_at),* FROM history; -- こんな風にかけるよ。

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

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

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

# 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
	}
}

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

# 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)]
	}
}

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はこちらからダウンロードできます。

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

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

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

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

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

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

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

ここから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"
}