Scripting Laboratory: grab command

スクリーンをロックする

Windows API や OSF/Motif APIで「モーダル」「モードレス」という言葉をご存知の方も多いと思います。簡単に言うと、モーダルなウィンドウとは、そのウィンドウが消えるまで他の処理が行えないウィンドウのことです。例えばアプリケーションソフトでは「そのファイルは既に存在します。上書きしますか？」というような確認には、YesかNoで答えるまで他のウィンドウの操作はできないようになっているのが普通です。 Tcl/Tkでは、あるウィンドウをモーダルにするのに grab というコマンドを使います。例えば、

    grab .dialog

とすると、以後 .dialog が消えるまでこのプログラム(wish)の他のウィンドウの操作はできなくなります。ただし、OS上で同時に走っている他のプログラムのウィンドウは操作できます。

    grab -global .dialog

とすると、今度はこのウィンドウが消えるまでスクリーン上の一切のウィンドウ操作ができなくなります。ですから逆に、ちゃんとウィンドウを消す処理 (あるボタンが押されたら消えるとか)をどこかに書いておかないと非常に面倒なことになります。

ここでは、この grab -global を使ってスクリーンをロックするスクリプトを作ってみました。普通のスクリーンロッカーは現在スクリーンがロックされているというのを遠目にもわかる画面を出しますが、「同僚が信用できないのか！」と周囲のみんなを剣呑にするのが怖いけど、やっぱり信用できないという方はこれで小さい窓を出しておき、その上であるパスワードを打つとロックが解けるようにしておくとよいかもしれません。ただし、「ハングアップした」と勘違いされて親切な同僚の方に勝手に再起動されてても知りません。

proc Start {filename} {
    global Passwd

    set w ""
    canvas $w.can -bg white
    image create photo TileImage -file $filename -format gif

    place $w.can -relx 0 -rely 0 -relw 1 -relh 1
    set imagewidth [image width TileImage]
    set imageheight [image height TileImage]

#    set windowwidth  [winfo screenwidth .]
#    set windowheight [winfo screenheight .]
    set windowwidth  $imagewidth
    set windowheight $imageheight
    . configure -width $windowwidth -height $windowheight

#    for {set y 0} {$y < $windowheight} {incr y $imageheight} {
#	for {set x 0} {$x < $windowwidth} {incr x $imagewidth} {
#	    $w.can create image $x $y  -image TileImage -anc nw
#	}
#    }
    $w.can create image 0 0 -image TileImage -anc nw

    bind . <Key> {
        # puts "%k - %K"
	if {! [string compare %K "Return"]} {
	    if {! [string compare $Passwd "password"]} {
	        catch {destroy .}
	    } else {
                bell; set Passwd {}
            }
        } else {
            set Passwd "${Passwd}%K"
        }
    }
}
set Passwd {}

global argv
if {[llength $argv] == 0} {
    puts "usage: grab.tcl imagefile"; exit
}
Start [lindex $argv 0]
bind . <Map> {
    grab -global .
    . configure -cursor hand2
}

(first uploaded 1999/01/13 last updated (not ever), Urano398)