Tcl で多重代入 [Tcl]
Perl をはじめとする多くのスクリプト言語には多重代入 [1] の機能がある。例えば以下は Perl プログラマなら絶対に書いたことがある定石コードだ。
($sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst) = localtime(time);
Tcl の set コマンドにはこんな風に複数の変数に1回で代入する機能は無い。でもそうした構文を新たに作るのはそんなに難しいことではない。多重代入を可能にするコマンドを let コマンドと名付けてみよう。
proc let {vars vals} {
for {set i 0} {$i < [llength $vars]} {incr i} {
set var [lindex $vars $i]
set val [lindex $vals $i]
uplevel 1 set $var $val; # set $var $val ではダメ
}
}
そうするとこんな風に書ける。
% let {a b} {12 34}
% puts "$a $b"
12 34
このコマンドは第1引数 vars で変数のリストを受け取って第2引数 vals で代入する値のリストを受け取る。繰り返しは見てのとおりだがその中で単に set を使って渡された変数名に代入しても上手く行かない。これは当たり前で Tcl では局所変数のスコープはプロシージャの中だからだ。ここでのトリックは uplevel コマンドを使うことである。
uplevel 1 args とするとコマンド args は「1レベル上のコンテキストで」実行される。だからここでは set コマンドがあたかも let コマンドの呼び出し元で実行されたかのような意味になるわけだ。
ところでこのコマンドの第1引数はリストなので当然要素数が1のリストでもよい。
% let a 123 % puts $a 123
しかし以下のような例では set コマンドの代替にはならない。
% let a "hello world" % puts $a hello % set a "hello world" hello world % puts $a hello world
Tcl ではスペースで区切られた文字列はリストとして解釈される。なので上の例では第1要素の hello が変数 a に代入されるだけになってしまうのだ。
Atom API を使う (記事の編集・削除篇) [Tcl]
「Atom API を使う (記事のポスト篇)」 [1] の続き。
「Tcl で HTTP の PUT/DELETE を行うには」 [2] の代替案のうち TclSOAP の CVS に置かれているバージョンの http モジュールを使ってみることにした。
その結果 PUT と DELETE をサポートするコードは以下のように。
set auto_path [concat . $auto_path]
package require sha1
package require base64
package require dom
package require http
set Username [lindex $argv 0]
set password [lindex $argv 1]
set url [lindex $argv 2]
namespace eval atompp {
variable id 1
proc geturlwsse {url Username password args} {
set nonce [expr rand()]
set Created [clock format [clock seconds] -format %Y-%m-%dT%H:%M:%SZ -gmt 1]
set PasswordDigest [base64::encode [sha1::sha1 -bin "$nonce$Created$password"]]
set Nonce [base64::encode $nonce]
set wssefmt {UsernameToken Username="%s", PasswordDigest="%s", Nonce="%s", Created="%s"}
set wsse [format $wssefmt $Username $PasswordDigest $Nonce $Created]
set token [eval [list ::http::geturl $url -headers [list X-WSSE $wsse]] $args]
upvar #0 $token state
return $token
}
proc getserviceuri {xml} {
set domdoc [::dom::DOMImplementation parse $xml]
set linkelems [::dom::selectNode $domdoc {/atom:feed/atom:link} \
-namespaces {atom http://purl.org/atom/ns#}]
set rels [list]
foreach linkelem $linkelems {
lappend rels [::dom::element getAttribute $linkelem rel]
lappend rels [::dom::element getAttribute $linkelem href]
}
return $rels
}
proc login {url username password} {
variable id
set handle atompp$id; incr id
variable $handle
set token [geturlwsse $url $username $password]
upvar #0 $token state
array set $handle [getserviceuri $state(body)]
set ${handle}(username) $username
set ${handle}(password) $password
return $handle
}
proc throw {handle uri title body {issued ""} } {
variable $handle
set posturl [set ${handle}(service.post)]
set username [set ${handle}(username)]
set password [set ${handle}(password)]
if {$uri == $posturl} {
set method POST
} else {
set method PUT
}
if {$issued == ""} {
set issued [clock format [clock seconds] -format %Y-%m-%dT%H:%M:%S]
}
set query [format {<?xml version="1.0"?>
<entry xmlns='http://purl.org/atom/ns#'
xmlns:dc='http://purl.org/dc/elements/1.1/' >
<title>%s</title>
<issued>%s</issued>
<content type='text/html' mode='escaped' xml:lang='ja-JP'>
%s
</content>
</entry>} \
[string map {& & < < > > \" " ' '} $title] \
$issued \
[string map {& & < < > > \" " ' '} $body] \
]
set query [encoding convertto utf-8 $query]
set token [geturlwsse $uri $username $password \
-query $query -type application/x.atom+xml \
-method $method
]
upvar #0 $token state
if {$method == "PUT"} {return $uri}
set domdoc [::dom::DOMImplementation parse $state(body)]
set edit [::dom::selectNode $domdoc {/atom:entry/atom:link[@rel='service.edit']} \
-namespaces {atom http://purl.org/atom/ns#}]
return [::dom::element getAttribute $edit href]
}
proc post {handle title body {issued ""}} {
variable $handle
set posturl [set ${handle}(service.post)]
throw $handle $posturl $title $body $issued
}
proc put {handle puturl title body {issued ""}} {
throw $handle $puturl $title $body $issued
}
proc delete {handle deleteurl} {
variable $handle
set username [set ${handle}(username)]
set password [set ${handle}(password)]
set token [geturlwsse $deleteurl $username $password -method DELETE]
}
}
set handle [::atompp::login $url $Username $password]
set edituri [atompp::post $handle title {テスト} 2005-06-04T23:24:52Z]
puts $edituri
atompp::put $handle $edituri title2 {テスト2} 2005-06-04T23:24:52Z]
atompp::delete $handle $edituri
1行目に set auto_path [concat . $auto_path] を入れているのは標準の http モジュールを上書きしたくないのでとりあえずカレントディレクトリに置いているためだ。
POST と PUT には共通点が多いので共通部分を throw プロシージャとして分離して共用するようにした。
そのほかの変更点は以下のとおり。
-issueタグを引数で指定できるようにした。指定が無い場合は現在時刻を使う。
-POST/PUTの時に投げる投稿内容の文字コードを encoding convertto で UTF-8 に変換するようにした。これは前回のコードでは日本語が文字化けしていたためで、何故かと思ったら http モジュールの内部で socket を常に fconfigure $s -translation binary としていたためで、これをやられるとチャネルの -encoding を binary にしたのと同じになってしまうのだ。外から指定ができないから文字列本体を予め変換しておくしかない。
だが実際に TclSOAP CVS 版の http を使ってみると、いわゆる printf デバッグ用の puts が所々にある状態でちょっとこれは使えないと感じた。もっと小奇麗にしたものが Tcl のメインに取り込まれればいいのだけど。
[1] http://blog.so-net.ne.jp/rainyday/2006-06-25
[2] http://blog.so-net.ne.jp/rainyday/2006-06-26
Tcl で HTTP の PUT/DELETE を行うには [Tcl]
Atom API を実装する途中に Tcl core の http パッケージでは HTTP PUT/DELETE が使えないということに気づいたわけですが (http://blog.so-net.ne.jp/rainyday/2006-06-25) 自分で実装するという手段のほかに以下のような代替手段があった。
-TclSOAP http://tclsoap.sourceforge.net/ の CVS に登録されている http パッケージを使う
TclSOAP の開発者が http パッケージを独自に拡張していて、このバージョンだと -method というオプションを使って PUT/DELETE ができる。でもパッケージングもされていなくてただ CVS にあるだけ。ちょっと気が進まない。
-TclCurl http://personal1.iddeo.es/andresgarci/tclcurl/english/ を使う
TclCurl は名前が示すとおり libcurl の Tcl バインディング。これは確かに多機能だし libcurl は以前アプリケーションを作ったときに使ったことがある。でもこれを使うと Pure Tcl ではなくなるところがたまにきず。あと今までのコードも TclCurl 用に全部置き換えなければいけない。
Atom API 使うという目的にとっては HTTP はただの下層なのであまり自分で書きたくはないところ。迷います。
Atom API を使う (記事のポスト篇) [Tcl]
前回 (http://blog.so-net.ne.jp/rainyday/2006-06-18) に引き続き今回は記事の投稿を実装します。
まず前回のコードをちょっとパッケージっぽく整理して、すべて atompp という名前空間に入れました。
で、ルートエンドポイントへのアクセスは atompp::login で行い、このプロシージャが返したハンドルを使って POST なりなんなりをするというデザインです。
package require http
package require sha1
package require base64
package require dom
set Username [lindex $argv 0]
set password [lindex $argv 1]
set url [lindex $argv 2]
namespace eval atompp {
variable id 1
proc geturlwsse {url Username password args} {
set nonce [expr rand()]
set Created [clock format [clock seconds] -format %Y-%m-%dT%H:%M:%SZ -gmt 1]
set PasswordDigest [base64::encode [sha1::sha1 -bin "$nonce$Created$password"]]
set Nonce [base64::encode $nonce]
set wssefmt {UsernameToken Username="%s", PasswordDigest="%s", Nonce="%s", Created="%s"}
set wsse [format $wssefmt $Username $PasswordDigest $Nonce $Created]
set token [eval [list ::http::geturl $url -headers [list X-WSSE $wsse]] $args]
upvar #0 $token state
return $token
}
proc getserviceuri {xml} {
set domdoc [::dom::DOMImplementation parse $xml]
set linkelems [::dom::selectNode $domdoc {/atom:feed/atom:link} \
-namespaces {atom http://purl.org/atom/ns#}]
set rels [list]
foreach linkelem $linkelems {
lappend rels [::dom::element getAttribute $linkelem rel]
lappend rels [::dom::element getAttribute $linkelem href]
}
return $rels
}
proc login {url username password} {
variable id
set handle atompp$id; incr id
variable $handle
set token [geturlwsse $url $username $password]
upvar #0 $token state
array set $handle [getserviceuri $state(body)]
set ${handle}(username) $username
set ${handle}(password) $password
return $handle
}
proc post {handle title body} {
variable $handle
set posturl [set ${handle}(service.post)]
set username [set ${handle}(username)]
set password [set ${handle}(password)]
set query [format {<?xml version="1.0"?>
<entry xmlns='http://purl.org/atom/ns#' xmlns:dc='http://purl.org/dc/elements/1.1/'>
<title>%s</title>
<issued>%s</issued>
<content type='text/html' mode='escaped' xml:lang='ja-JP'>
%s
</content>
</entry>} \
[string map {& & < < > > \" " ' '} $title] \
[clock format [clock seconds] -format %Y-%m-%dT%H:%M:%S] \
[string map {& & < < > > \" " ' '} $body] \
]
set token [geturlwsse $posturl $username $password -query $query]
upvar #0 $token state
set domdoc [::dom::DOMImplementation parse $state(body)]
set edit [::dom::selectNode $domdoc {/atom:entry/atom:link[@rel='service.edit']} \
-namespaces {atom http://purl.org/atom/ns#}]
return [::dom::element getAttribute $edit href]
}
}
set handle [atompp::login $url $Username $password]
atompp::post $handle title body
atompp::post プロシージャはハンドルとタイトル、本文を引数にとり、投稿後に作成された記事の EditURI を返します。
Atom PP の仕様ではこの EditURI に対して PUT や DELETE を行うことによって更新や削除を行います。
…とここまで作って気がついたのですが Tcl の標準の http モジュールはどうやら GET/HEAD/POST のみの対応で PUT や DELETE ができない！ うーん、どうしよう。
Tcl で memoization [Tcl]
今読んでいる本のひとつに Higher Order Perl というのがあって―これは本当にすばらしい本で、いずれじっくり紹介したいのだが―その本の中で解説されているテクニックのひとつに memoization がある。
これは関数の結果をキャッシュして、キャッシュがヒットしたら再計算をせずにキャッシュを返すというものだ。
単純なバージョンではこんな memoize 関数を作る。
sub memoize {
my ($func) =@_;
my %cache;
my $stub = sub {
my $key = join ',', @_;
$cache{$key} = $func->(@_) unless exists $cache{$key};
return $cache{$key};
};
return $stub;
}
この関数は関数を引数にとって memoized 版の関数を返す。
新しく作られる関数の中では、引数をキーにしたハッシュを保持して、関数が呼び出されたときに引数に対応するハッシュ値があればそれを返して、無かったら元々の関数を呼び出してハッシュに今回の結果をキャッシュする、ということをしている。
例えば fib という関数があってそれを memoize するには以下のように使う。
sub fib {
my ($month) = @_;
if ($month < 2) { 1 }
else {
fib($month-1) + fib($month-2);
}
}
*fib = memoize(\&fib);
このようにすると元の fib 関数には手をつけることなく、そっくりそのまま fib が memoized 版に置き換わる。
ちなみに fib というのはフィボナッチ数列というものを計算する関数で、これは内部で再起呼び出しを頻繁に行うのでキャッシュの効果が絶大に現れる例としてよく使われるようだ。
それでこれを Tcl でやったらどうなるだろうかと考えた。
でも Tcl の世界ではこういったことは大抵の場合自分が考える前に Tcler's Wiki に書いてあるものだ。実際探してみると以下のようなページがある。
http://wiki.tcl.tk/10981
http://wiki.tcl.tk/10779
でもここで提案されているコードはプロシージャの定義の先頭に memoize という記述を埋め込むものだったり proc の代わりに memproc という定義をするものだったりして、「すでに存在するプロシージャに手をつけずに memoize する」という条件を満たすものではないようだ。
その要件を満たすための Tcl での正攻法は以下のようなものじゃないだろうか。
namespace eval memoise {
variable id 1
proc memoise {f} {
variable id
set oldname [namespace origin $f]
set newname f$id
rename $oldname $newname
set fullnewname [namespace origin f$id]
set curns [namespace current]
proc $oldname {args} "
if \[info exists ${curns}::cache${id}(\$args)\] {
return \$${curns}::cache${id}(\$args)
}
set ${curns}::cache${id}(\$args) \[eval $fullnewname \$args\]
return \$${curns}::cache${id}(\$args)
"
incr id
}
}
proc fib x {expr {$x <=1? 1 : [fib [expr {$x-1}]] + [fib [expr {$x-2}]]}}
puts [time {puts fib30=[fib 30]}]
memoise::memoise fib
puts [time {puts fib30=[fib 30]}]
この memoize::memoize 関数は渡された名前のプロシージャをリネームして memoize 名前空間内に退避する。その後、元の名前のプロシージャを memoized 版として再定義する。
リネーム後のプロシージャ名は memoize が呼ばれるたびに memoize::f1, memoize::f2, ... と使われていくので衝突することはない。キャッシュの配列も同様に memoize 名前空間内に存在する。
proc $oldname のあたりはどういう置き換えが発生しているかじっくり考えないと分かりにくいかもしれないが、これは中カッコでなくて二重引用符なので内部の $ や [] が置き換わって、その結果がプロシージャの定義になる。
上記のコードの実行例は以下のようになる。
fib30=1346269 6401381 microseconds per iteration fib30=1346269 2326 microseconds per iteration
計算結果に影響を与えずに実行速度が向上しているのが分かる。
So-net blog の AtomAPI を使う (ルートエンドポイント篇) [Tcl]
この So-net blog には AtomAPI (最近ではAtomPP: Atom Publishing Protocol) を使って記事を投稿する機能があるらしい。
http://www.so-net.ne.jp/blog/sitetour/atom_api_spec.html
ちょっと使ってみたいと思ってまずは Perl の XML::Atom をインストールしようとしたけどめんどくさくて放り投げる。せっかくだから Tcl で自分でごりごり書いてみようと思います。
Atom API ではまずはルートエンドポイントという URL にアクセスしてブログの情報を取得するところからはじめるようだ。
ネットでみつけたコードとかを参考にして Tcl で実装したのがこれ。
sha1 や base64 は tcllib パッケージを使用。
package require http
package require sha1
package require base64
set Username [lindex $argv 0]
set password [lindex $argv 1]
set nonce [expr rand()]
set Created [clock format [clock seconds] -format %Y-%m-%dT%H:%M:%SZ -gmt 1]
set PasswordDigest [base64::encode [sha1::sha1 -bin "$nonce$Created$password"]]
set Nonce [base64::encode $nonce]
set wssefmt {UsernameToken Username="%s", PasswordDigest="%s", Nonce="%s", Created="%s"}
set wsse [format $wssefmt $Username $PasswordDigest $Nonce $Created]
set token [::http::geturl {http://blog.so-net.ne.jp/_atom/blog} \
-headers [list X-WSSE $wsse]]
upvar #0 $token state
puts $state(body)
さて実行してみると、、
<!DOCTYPE html
PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="ja" lang="ja">
<head>
<meta http-equiv="content-type" content="text/html; charset=UTF-8" />
<meta http-equiv="Content-Script-Type" content="text/javascript" />
<meta http-equiv="Content-Style-Type" content="text/css" />
<title>So-net blog : システムエラーが発生いたしました。</title>
…。念のため BlogWrite という Atom API 対応ソフトウェアで接続してみても同じなのでサーバが原因のようだ。
[2006-06-20追記] 念のため Livedoor Blog でやってみたらちゃんと動く。おかしいなと思ったら勘違いをしていたことに気づいた。このブログの場合Atom API のユーザIDは ether ではなくて rainyday になるのが正しい！
それにしても 40x ではなくて 505 になってしまってるのはどうかと思うが。
[2006-06-20追記]
というわけで取得ができたので結果の XML を処理する。
このリクエストで得られる情報というのは PostURI, FeedURI, UploadURI という3つの URI で、これらが今後の処理の次の足がかりになる。
<?xml version="1.0" encoding="utf-8"?> <feed xmlns="http://purl.org/atom/ns#"> <link rel="service.post" href="http://blog.so-net.ne.jp/_atom/blog/1" type="application/x.atom+xml" title="user_nameのブログ" /> <link rel="service.feed" href="http://blog.so-net.ne.jp/_atom/blog/1" type="application/x.atom+xml" title="user_nameのブログ" /> <link rel="service.upload" href="http://blog.so-net.ne.jp/_atom/image/1" type="application/x.atom+xml" title="user_nameのブログ" /> </feed>こういうデータは基本的にハッシュの構造なので Tcl のハッシュにしてしまおう。 XML 処理のコードを追加して以下のようにした。
package require http
package require sha1
package require base64
package require dom
set Username [lindex $argv 0]
set password [lindex $argv 1]
set url [lindex $argv 2]
set nonce [expr rand()]
set Created [clock format [clock seconds] -format %Y-%m-%dT%H:%M:%SZ -gmt 1]
set PasswordDigest [base64::encode [sha1::sha1 -bin "$nonce$Created$password"]]
set Nonce [base64::encode $nonce]
set wssefmt {UsernameToken Username="%s", PasswordDigest="%s", Nonce="%s", Created="%s"}
set wsse [format $wssefmt $Username $PasswordDigest $Nonce $Created]
set token [::http::geturl $url -headers [list X-WSSE $wsse]]
upvar #0 $token state
set xml $state(body)
set domdoc [::dom::DOMImplementation parse $xml]
set linkelems [::dom::selectNode $domdoc {/atom:feed/atom:link} \
-namespaces {atom http://purl.org/atom/ns#}]
set rels [list]
foreach linkelem $linkelems {
lappend rels [::dom::element getAttribute $linkelem rel]
lappend rels [::dom::element getAttribute $linkelem href]
}
array set linkh $rels
puts "service.upload: $linkh(service.upload)"
puts "service.post: $linkh(service.post)"
puts "service.feed: $linkh(service.feed)"Wiki 記法のパーサを作る [Tcl]
今回は手近なところで Tcl を使って Wiki 記法のパーサを作ってみようと思う。
これは以前 Tcl で Wiki 記法を採用したソフトウェアを作成したけどあまり美しくないやりかたでゴリゴリ書いていたのでプログラム的に触りにくいものになってしまった反省というのもある。
Tcl でパーサを作成するのためのライブラリはいくつかあるが、今回は Yeti/Ylex を使う。
http://www.fpx.de/fp/Software/Yeti/
Wiki 記法の文法は以下のとおりとする。
-記事は空行区切りで並べられたブロック要素群である。
-「*」で始まるブロックは見出しである。レベル6見出しまで対応
-「-」で始まるブロックは順序なしリストである。
-「+」で始まるブロックは順序ありリストである。
-それ以外のブロックは段落である。
まずは字句解析器を作る。Ylex では
1. yeti::ylex をインスタンス化してスキャナジェネレータを作る
2. add メソッドを使ってスキャナを定義
3. dump メソッドを eval するとスキャナのクラスができる
4. スキャナクラスをインスタンス化するとスキャナができる
という、ちょっとややこしい手順を踏む。
set sg [yeti::ylex #auto -name wikiscan]
$sg add {
{\+([^\n]*\n)} { return [list PLUS $1] }
{-([^\n]*\n)} { return [list MINUS $1] }
{(\*{1,6})([^\n]*\n)} { return [list ASTERISK[string length $1] $2] }
{[^\n]+\n} { return [list LINE $yytext] }
{\n} { return BLANK_LINE }
}
eval [$sg dump]; delete object $sg
set scanner [wikiscan #auto]
基本的に行ベースでトークン化している。アスタリスクで始まる行はちょっとズル？をして1行にまとめた。
このコードでは sg がスキャナジェネレータで、wikiparse がスキャナのクラスで、scanner がスキャナである。
次は Yeti を使った構文解析。これも Ylex と同様の遠まわしなやり方になる。
set pg [yeti::yeti #auto -name wikiparse]
$pg add {
start {BLOCKS BLANK_LINES} {return $1}
BLANK_LINES {BLANK_LINE} {}
BLANK_LINES {BLANK_LINES BLANK_LINE} {}
BLOCKS {} {}
BLOCKS {BLOCK} {return $1}
BLOCKS {BLOCKS BLANK_LINES BLOCK} {return $1$3}
BLOCK {P} {return "<p>$1</p>\n"}
BLOCK {H1} {return "<h1>$1</h1>\n"}
BLOCK {H2} {return "<h2>$1</h2>\n"}
BLOCK {H3} {return "<h3>$1</h3>\n"}
BLOCK {H4} {return "<h4>$1</h4>\n"}
BLOCK {H5} {return "<h5>$1</h5>\n"}
BLOCK {H6} {return "<h6>$1</h6>\n"}
BLOCK {OL} {return "<ol>$1</ol>\n"}
BLOCK {UL} {return "<ul>$1</ul>\n"}
P {LINES} {return $1}
H1 {ASTERISK1} {return $1}
H1 {ASTERISK1 LINES} {return $1$2}
H2 {ASTERISK2} {return $1}
H2 {ASTERISK2 LINES} {return $1$2}
H3 {ASTERISK3} {return $1}
H3 {ASTERISK3 LINES} {return $1$2}
H4 {ASTERISK4} {return $1}
H4 {ASTERISK4 LINES} {return $1$2}
H5 {ASTERISK5} {return $1}
H5 {ASTERISK5 LINES} {return $1$2}
H6 {ASTERISK6} {return $1}
H6 {ASTERISK6 LINES} {return $1$2}
OL {OLI} {return $1}
OL {OL OLI} {return $1$2}
OLI {PLUS} {return "<li>$1</li>\n"}
OLI {PLUS LINES} {return "<li>$1$2</li>\n"}
UL {ULI} {return $1}
UL {UL ULI} {return $1$2}
ULI {MINUS} {return "<li>$1</li>\n"}
ULI {MINUS LINES} {return "<li>$1$2</li>\n"}
LINES {LINE} {return $1}
LINES {LINE LINES} {return $1$2}
}
eval [$pg dump]; delete object $pg
set parser [wikiparse #auto -scanner $scanner]
pg がパーサジェネレータで wikiparse がパーサのクラスで parser がパーサである。こっちは H1 から H6 までをまとめる方法が思いつかなかったので愚直に書いた。
実際にパーシングを行うには以下のようにする。
$scanner start {
*見出し1
段落
**見出し2
-リストA
-リストB
+リスト1
+リスト1
}
$parser reset
puts [$parser parse]
delete object $parser
実行結果は以下のとおり。ちゃんとできた。
<h1>見出し1 </h1> <p>段落 </p> <h2>見出し2 </h2> <ul><li>リストA </li> <li>リストB </li> </ul> <ol><li>リスト1 </li> <li>リスト1 </li> </ol>
ether さん
-
nice! 34
記事 322
テーマ パソコン・インターネット
プロフィール
ブログを紹介する
--
