カテゴリー別アーカイブ: Programming

プログラミングの話題

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

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

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

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

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

# 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

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

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

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

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

ファイル名を引数に与えると、標準出力に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を起動し、

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