Super Technique 講座

Tcl/Tk によるGUI(2)

John Ousterhout の作った言語 Tcl/Tk は、非常に便利な言語である。これは簡単なスクリプト言語の側面と、GUIツールキットの二面性を持ち、そのために多彩な理用法が可能である。ここで、筆者が経験した多様な使い方を紹介し、Tck/Tk の有効性について議論しよう。やや未完成なかたちで公開するが、それでも有益だろう。そのうち追加するので待っていて欲しい...とかつて書いたが、約1年開いてしまったがここに後編をお届けする。考えてみるとすでに結構「レトロコンピューティング」になってしまったような気がしないでもない(苦笑)。

1年開いてしまった理由は、ちょっと 8.0 系にバグがあるようで、Tk 自前ウィジットがうまく作れなかった...どうしよう?と思っているうちに忘れちゃったんだな、これが。で、新マシンに移行して 8.3 系を入れて、それでやってみると大体動くじゃん。というわけで、改めてヤル気になったわけだ。で、ここで 8.1 から新たに採用された Tcl_Obj 型があるんで、結構新しい API が増えている。だから、こういう新しい API を使い倒したものって、ニーズがあるかしらん?ということで書いたわけである。最近ではかつてあんなに強かった「ポインタ虎の巻」がアクセス数が減っている御時世だ。どうやら筆者もいわゆる「真のプログラマ(Real Programmer)」になりつつあるのかな?

「真のプログラマ(Real Programmer)」はホメ言葉じゃないぞ。Jargon File によると、「ハッカーの特殊なバリエーション。経験の裏付けがあるにせよ、複雑なものに対して傲慢なまでに軽い態度を取る人。典型的な真のプログラマは素の金物でプログラミングするのを好み(要するに生の機械語コードで書くのが得意)...真のプログラマは仕様書に決して書いてなかったようなことをマシンに実行させられる。というか、そうしなければめったに心からの満足を得られない。真のプログラマのコードは畏敬の念を起こさせるほと魔性の才気にあふれている一方で、あまりにきわどくて見る者の背筋を寒くさせる...ほかのプログラマの恐怖の的となる...そういうプログラマの後継者たちは、真のプログラマが最近あまりいなくなったのをいいことだと見なしている」。さすがに筆者はここまでスゴくはないと思うが、それでも時流との相対的な関係でそうなるかもしれないな。やれやれ。

済まぬが量がちょっと異常になってしまった。それゆえ前編・後編と分けて記述する。続けて読まれたい。

前編

後編


C言語によって自前の Tk ウィジットを新たに作る!

さて、前編の「C言語によって自前コマンドを処理できるインタプリタを作成する!」では 自作のTcl コマンドを解釈できるインタプリタを作成したのだが、当然自作のTk ウィジットコマンドを解釈できるインタプリタも作成できる。しかし、Tcl コマンドよりも多くのコールバックを定義し、いろいろとリソースを定義しなければならない。だから割と面倒ではある。

ここで驚愕の事実が判明する。それは「Tk っていうと、ウィジットを作成して、ウィジットにコマンドを与えてGUIを作るんだよね〜〜」という説明はまったくウソなのだ。実は、先程HTTPコマンドが「http0」というような、その場限りのコマンドを作成し、それを使ったのだが、実は実装上は .button のようなパス付きのウィジット名というのも、このような「その場限りの使い捨てコマンド」なのである。「そうだったのか... 俺はもう人生を信じられない!」という風に悲観しないで欲しい。

まあ、これは考えてみるに、Tcl/Tk の設計者が smalltalk のような一種の「メッセージ・モデル」によって、言語を設計した結果なのだとも言える。つまり、button とか frame とかのコマンドは、実はインスタンスを作成するコマンドであって、第1引数のかたちで新たに制作するインスタンスの名前をメッセージとして与え、そのインスタンスを作成する。そして、そのインスタンスにメッセージを与えて具体的な動作を規定しているのである。とはいえ、Tck/Tk はホントのオブジェクト指向言語ではないから、継承はできない(多相っぽい動作は実装しようと思えば出来るけど...)。まあ、そういう継承を欠いた「オブジェクト・モドキ言語」である、ということを理解して、新規のウィジットとして button ウィジットのサブセットを作ってみよう。

これは説明のために作成したものなので、超手抜きである。実は新たにウィジットを作るのはコールバックが多くて結構面倒なのだ。なので、「Tkっぽい!(いいかえれば Motif っぽい3D表示)」表示でもないし、FocusIn とか MouseEnter とかのイベントによって見かけが変わる...なんて高度なことはまったくしていない(Xlib版みたいな感じ)。あまり細かいXプログラムで読者を煩わせたくないしね...だから対応しているオプションもこれだけだ。

-background(-bg), -foreground(-fg), -anchor, -font, -justify, -text, -command

まあ、一応 -command とかにも対応しているので、「ボタンである!」と言ってもそう問題ではないな。で、こういう風にオプションに対応する、ということは「そのオプションの定義が必要になる」ことであるのは、賢明な読者はきっと察することであろう。要するに「オプションテーブル」が要るのである。こういう「オプションテーブル」を簡便に処理する関数が Tk に既に用意されているので、それを使っていく。で、tcl/tk8.1 から、さまざまなオプション値を処理するのに、基本データ型を使うのではなくて、Tcl_Obj という汎用的なデータ型を使ってやる、という新しいAPI体系が用意されたので、こっちを使ってみよう(古い方もまだあるが..)。なので、8.0 以前のバージョンではコンパイルできないので、そのつもりで(筆者は8.3でやっている)。

また、そういう「オプションをウィジットとして保持する」ことも必要だ。だから、ウィジットの実体として、いろいろな情報(Xで使う情報なども一緒に)を保持する構造体が必要になるわけである。まず、こういう構造体とオプションテーブルを先に示そう。

#include <X11/X.h>
#include <tcl.h>
#include <tk.h>
#include <stdio.h>
#include <malloc.h>
#include <string.h>
#include <stdlib.h>

/* 自作ボタンの定義構造体 */
typedef struct {
   /* まずデフォルトで必要なウィジット基本データ */
   Tk_Window tkwin;   /* Window の実体 */
   Display *display;   /* X の Display * */
   Tcl_Interp *interp; /* Tcl インタプリタ */
   Tcl_Command widgetCmd; /* ウィジットコマンドのコールバック */
   Tk_OptionTable optionTable; /* オプションテーブル */

   /* 背景色(3D描画があるので、Tk_3DBorder型)*/ 
   Tk_3DBorder bgBorder;  /* -background or -bg */
   /* 前景色(文字の色)なので、XColor型 */
   XColor *fgColor;      /* -foreground or -fg */
   Tk_Anchor anchor; /* -anchor。アンカー位置 */
   Tk_Font font;        /* -font */
   Tk_Justify justify;   /* -justify */

   /* 表示文字とコマンド。これらは文字列なので、Tcl_Obj 型で受ける */
   Tcl_Obj *text;     /* -text */
   Tcl_Obj *command;   /* -command */

   /* 表示の用途で内部で保持するデータ */
   Tk_TextLayout layout;  /* レイアウト計算 */
   GC gc;             /* Graphic Context */
   int textWidth;       /* 表示文字の幅(pixel) */
   int textHeight;      /* 表示文字の高さ(pixel) */

   /* 再描画すべきかどうかを判定するフラグ(遅延実行)*/
   int updatePending;
} MyButton;


/* オプション定義を処理するためのテーブル */
Tk_OptionSpec MyButtonSpecs[] = {
   /* { Type, 引数として使われる名前, DB内で使われる名前, DB内で使われるクラス名, 
      デフォルト値, Tcl_Obj型として保存される値の構造体内でのオフセット(-1=非保存),
      変換された後の値が保存される構造体内でのオフセット(-1=非保存),オプションフラグ,
      代替デフォルト値(白黒ディスプレイのケースなど),typemask }, */
   { TK_OPTION_BORDER, "-background", "background", "Background", "#cdb79e", 
     -1, Tk_Offset(MyButton,bgBorder), 0, (ClientData)"White", 0 },
   { TK_OPTION_SYNONYM, "-bg", NULL, NULL, NULL, 
     0, -1, 0, (ClientData)"-background", 0 },
   { TK_OPTION_COLOR, "-foreground", "foreground", "Foreground", "#b03060", 
     -1, Tk_Offset(MyButton,fgColor), 0, 0, 0 },
   { TK_OPTION_SYNONYM, "-fg", NULL, NULL, NULL, 
     0, -1, 0, (ClientData)"-foreground", 0 },
   { TK_OPTION_ANCHOR, "-anchor", "anchor", "Anchor", "center", 
     -1, Tk_Offset(MyButton,anchor), 0, 0, 0 },
   { TK_OPTION_FONT, "-font", "font", "Font", "Helvetica -12 bold",
     -1, Tk_Offset(MyButton,font), 0, 0, 0 },
   { TK_OPTION_JUSTIFY,"-justify", "justify", "Justify", "center",
     -1, Tk_Offset(MyButton,justify), 0, 0, 0 },

   { TK_OPTION_STRING, "-text", "text", "Text", "", 
     Tk_Offset(MyButton,text), -1, 0, 0, 0 },
   { TK_OPTION_STRING, "-command", "command", "Command", "", 
     Tk_Offset(MyButton,command), -1, TK_OPTION_NULL_OK, 0, 0 },

   { TK_OPTION_END, NULL, NULL, NULL, NULL, 
     0, -1, 0, 0, 0 }
};

で、Tcl コマンドの作成と同様に、「コールバックによるプログラミング」のモデルに従っている。コールバックとして要求される関数が、やはりウィンドウプログラミングなので「イベントコールバック」と「アイドルコールバック」と2つ増えている。また、オプションを設定する関数は厳格にはコールバックではないが、それに準じる必須関数とされている。

/* 必要なコールバックは...*/
/* Widet 作成 */
int MyButtonCmd( ClientData cd, Tcl_Interp *interp, int argc, Tcl_Obj **argv );
/* Widget コマンドのコールバック */
int MyButtonWidgetCmd( ClientData cd, Tcl_Interp *interp, int argc, Tcl_Obj **argv);
/* 削除コールバック */
void MyButtonDeletedProc( ClientData cd );
/* Tk で増えるコールバックは... */
/* アイドルコールバック(実質上描画処理)*/
void MyButtonIdle( ClientData cd );
/* イベントコールバック */
void MyButtonEventProc( ClientData cd, XEvent *event );

/* Widget configure などの設定をする内部関数 */
int MyButtonConfigure( Tcl_Interp *interp, MyButton *MBp, int argc, Tcl_Obj **argv );
/* 再描画内部関数 */
static void MyButtonRedraw( ClientData cd );

で、メインルーチンだ。これはたとえば次のような Tcl/Tk コマンドファイルを読み込んで実行する(tkbut.tcl)。

mybutton .mb1
mybutton .mb2
.mb1 configure -bg blue -fg red -text "echo" -command { puts "test" }
.mb2 configure -bg red -fg blue -text "exit" -command { exit 0 }
pack .mb1 -side left
pack .mb2 -side right

メインルーチン自体は、Tcl 版とそうひどくは違わない。違いは Tcl_CreateCommand() が、Tcl_CreateObjCommand() になったくらいのものである。

/* メインルーチン */
int main( int argc, char **argv )
{
   Tcl_Interp *interp;
   char *file = "./tkbut.tcl";
   Tcl_Command ret;

   interp = Tcl_CreateInterp();

   if( Tcl_Init( interp ) == TCL_ERROR ){
      fprintf( stderr, "%s\n", interp->result );
      exit( 1 );
   }
   if( Tk_Init( interp ) == TCL_ERROR ){
      fprintf( stderr, "Tk_Init failed:%s\n", interp->result );
      exit( 1 );
   }

   /* ウィジット初期化...今回は Tcl_Obj版を使う */
   ret = Tcl_CreateObjCommand( interp, "mybutton", (Tcl_ObjCmdProc *)MyButtonCmd, 
                 (ClientData)NULL, (Tcl_CmdDeleteProc *)NULL );
   if( ret == NULL ){
      fprintf( stderr, "Dith_Init failed:%s\n", interp->result );
      exit( 1 );
   }

   /* Tcl/Tkコマンドを評価 */
   if( Tcl_EvalFile( interp, file ) == TCL_ERROR ){
      fprintf( stderr, "%s TCL error\n", file );
      fprintf( stderr, "%s\n", interp->result );
      exit( 1 );
   }

   /* メインループ */
   Tk_MainLoop();
   return( 0 );
}

で今からコールバックだ。まずは作成コールバックだが、これは Tcl_Obj版なので、今までは char ** だった argv が Tcl_Obj ** になっているあたりにご注意されたい。勿論直接文字列として扱えないわけで、Tcl_Obj 型に文字列データが入っているケースでも、Tcl_GetString() を使って文字列を取得する必要があるわけである。最初に見る MyButtonCmd コールバック関数は、言うまでもなく「mybutton パス名」で呼ばれた時に実行されるコールバックだ。

まあ、これはそうひどく難しいものではなかろう。要するに、

  1. デフォルトのオプションテーブルを用意し、
  2. 引数で渡る「パス名」から実ウィンドウを作成し、
  3. このウィジットを管理するデータ構造体 MBp を作成してNULL初期化し、
  4. 「ウィジットコマンドのハンドラ」と「イベントハンドラ」を登録し、
  5. データ構造体をオプションテーブルで初期化し、
  6. 引数による個別オプションを設定する

という流れのものだ。

/* 今から各コールバックの定義 */
/* まず初期化から呼ばれるコマンド作成コールバック */
int MyButtonCmd( ClientData cd, Tcl_Interp *interp, int argc, Tcl_Obj **argv )
{
   MyButton *MBp;
   Tk_Window tkwin;
   Tk_OptionTable options;
   Tk_Window mainw = Tk_MainWindow( interp );
   char *winName;
   Tcl_CmdInfo info;
   char *name;

   options = (Tk_OptionTable)cd;
   if( options == NULL ) {
      /* 最初に呼ばれた時には ClientData が NULL で、ウィジット共通の
         デフォルト値を設定する */
      options = Tk_CreateOptionTable( interp, MyButtonSpecs );
      /* 2回目以降に ClientData にデフォルトの OptionTable が渡るようにする */
      name = Tcl_GetString( argv[0] );
      Tcl_GetCommandInfo( interp, name, &info );
      info.objClientData = (ClientData)options;
      Tcl_SetCommandInfo( interp, name, &info );
   }

   if( argc < 2 ) {
      Tcl_WrongNumArgs( interp, 1, argv, "pathName ?options?" );
      return TCL_ERROR;
   }

   /* 実際にウィンドウを作成する(ホントは遅延作成になる)*/
   winName = Tcl_GetString( argv[1] );
   tkwin = Tk_CreateWindowFromPath( interp, mainw, winName, NULL );
   if( tkwin == NULL ) {
      printf( "MyButtonCmd failed create %s\n", winName );
      return TCL_ERROR;
   }
   Xのレベルでの「クラス」を設定する
   Tk_SetClass( tkwin, "MyButton" );

   /* MyButton のデータ構造体を作成する */
   MBp = (MyButton *)malloc( sizeof(MyButton) );
   memset( MBp, 0, sizeof(MyButton) );

   /* データ構造体の初期化 */
   MBp->tkwin = tkwin;
   MBp->display = Tk_Display(tkwin);
   MBp->interp = interp;
   /* 第2引数が「作成されるコマンド」=「ウィジットパス名」
     の関係になっていることに注意。あれは使い捨ての「コマンド」
     なのである。 */
   MBp->widgetCmd = Tcl_CreateObjCommand( interp, Tk_PathName(tkwin),
               (Tcl_ObjCmdProc *)MyButtonWidgetCmd, (ClientData)MBp, 
               MyButtonDeletedProc );
   MBp->optionTable = options;

   MBp->anchor = TK_ANCHOR_CENTER;
   MBp->bgBorder = NULL;   MBp->fgColor = NULL;
   MBp->font = NULL;      MBp->justify = TK_JUSTIFY_CENTER;

   MBp->layout = NULL;     MBp->gc = None;
   MBp->updatePending = 0;

   /* イベントハンドラの登録 */
   /* ホントは EnterWindowMask とか LeaveWindowMask, ButtonPressMask
      なんかにも対応すべきなのだが... */
   Tk_CreateEventHandler( tkwin, ExposureMask | StructureNotifyMask | ButtonReleaseMask, 
      MyButtonEventProc, (ClientData)MBp );

   /* デフォルトオプションの登録 */
   if( Tk_InitOptions( interp, (char *)MBp, options, tkwin ) != TCL_OK ) {
      Tk_DestroyWindow( tkwin );
      printf( "MyButtonCmd: failed Tk_InitOptions\n" );
      return TCL_ERROR;
   }

   /* 初期化引数によるオプションの設定 */
   if( MyButtonConfigure( interp, MBp, argc - 2, argv + 2 ) != TCL_OK ) {
        Tk_DestroyWindow( MBp->tkwin );
        printf( "MyButtonCmd: failed MyButtonConfigure\n" );
        return TCL_ERROR;
    }

   /* 正常のコマンド終了結果の格納 */
   Tcl_SetStringObj( Tcl_GetObjResult(interp), Tk_PathName(tkwin), -1 );
   return TCL_OK;
}

次はウィジットコマンドのハンドラだ。これは作成したウィジットに対してコマンドを与えた時にコールバックされる関数だ。「.mb1 configure...」とかしたケースである。だから「どういうコマンドに対応するのか?」のリストが必要になり、これは文字列配列であらかじめ用意しておくと、簡単に処理できる関数が用意されている。で、個別のコマンドに対応して、「設定内容を取得(cget)」「設定情報の表示(configure -bg のみ)」「設定する(configure -bg red)」などを処理するAPIを呼び出せば良いだけだ。ここらへんはかなり定型的な上に、それを助ける API が既に用意されていたりするのでカンタンだ。

/* 存在するウィジットコマンドのリスト */
char *commandNames[8] = { "cget", "configure", NULL };

/* ウィジットコマンドのハンドラ */
int MyButtonWidgetCmd( ClientData cd, Tcl_Interp *interp, int argc, Tcl_Obj **argv)
{
   MyButton *MBp = (MyButton *)cd;
   int result;
   int index;
   Tcl_Obj *op;

   if (argc < 2) {
      Tcl_WrongNumArgs( interp, 1, argv, "Option ?arg arg ..?" );
      return TCL_ERROR;
   }
   /* 存在するコマンドのリスト(commandNames)から、与えられたコマンド(argv[1])
      のどれに相当するか検索する */
   result = Tcl_GetIndexFromObj( interp, argv[1], commandNames, "option", 0, &index );
   if( result != TCL_OK ) {
      return result;
   }

   /* 設定中なのにデータが解放されるのを防ぐ */
   Tcl_Preserve((ClientData) MBp);

   if( index == 0 ) { /* cget */
      if( argc != 3 ) {
         Tcl_WrongNumArgs( interp, 1, argv, "cget option" );
         goto error;
      }
      /* 設定内容を取得し */
      op = Tk_GetOptionValue( interp, (char *)MBp, MBp->optionTable, argv[2],
                        MBp->tkwin );
      if( op == NULL ) goto error;
      /* 結果に格納 */
      Tcl_SetObjResult( interp, op );
   } else if( index == 1 ) { /*configure */
      if( argc <= 3 ) {  /* .mybutton configure -background */
         /* 設定情報を取得して結果に格納 */
         op = Tk_GetOptionInfo( interp, (char *)MBp, MBp->optionTable,
                           (argc==3)?(argv[2]):NULL, MBp->tkwin );
         if( op == NULL ) goto error;
         Tcl_SetObjResult( interp, op );
      } else {  /* .mybutton configure -background red */
         /* 設定する */
         result = MyButtonConfigure( interp, MBp, argc-2, argv+2 );
      }
   }
   /* 解放してよし */
   Tk_Release( (ClientData)MBp );
   return result;
 error:
   Tk_Release( (ClientData)MBp );
   return TCL_ERROR;
}

しかし、オプションを変更したりした場合(新規作成を含む)には、当然ウィジットの表示変更がついて回る。なので、とりあえず MyButtonDraw という内部関数を用意しておいて、この部分だけは別関数にしておく。それを除けば、単に API を使うだけだし、うまく出来たもので、オプションに異常があった場合には「すべてのオプション変更をキャンセル」できるようになっている。もちろんここで API によるカンタン設定を補うような自前のオプション処理をしてもOKだ。それは単純に Tcl_Obj 型でオプション文字列を受けてやって、自力で Tcl_Obj 型データから「使うデータ」を構築してやるまでのことである。

/* 「設定」をする内部関数。ウィジット作成時と configure コマンドで呼ばれる */
static int MyButtonConfigure( Tcl_Interp *interp, MyButton *MBp, int argc, Tcl_Obj **argv )
{
   Tk_SavedOptions saved;
   int error = 0;

   /* オプションを設定する...簡単だ */
   if( Tk_SetOptions( interp, (char *)MBp, MBp->optionTable, argc, argv,
                  MBp->tkwin, &saved, NULL ) != TCL_OK ) {
      error = 1;
   }
   /* オプション設定の結果を表示に反映させる */
   MyButtonRedraw( (ClientData)MBp );
   if( error ) {
      /* オプション変更を破棄する */
      Tk_RestoreSavedOptions( &saved );
      Tcl_SetObjResult( interp, Tcl_GetObjResult(interp) );
      return TCL_ERROR;
   } else {
      Tk_FreeSavedOptions( &saved );
      return TCL_OK;
   }
}

さて、ようやくウィンドウプログラミングらしい部分に突入する。描画関数 MyButtonRedraw である。しかし、これもまだ実作業はせずに、「描画をするための準備(GCとか作成)」をするに過ぎない。要するにウィンドウプログラミングらしく、アイドルコールバックでホントの描画をさせるのであり、ここでは「実際の描画をするアイドルコールバック」をスケジュールするだけのことである。

/* 表示を担当する内部関数 */
static void MyButtonRedraw( ClientData cd )
{
   XGCValues gcv;
   GC gc;
   unsigned long mask;
   MyButton *MBp = (MyButton *)cd;

   /* GC の作成 */
   gcv.font = Tk_FontId(MBp->font);
   gcv.foreground = MBp->fgColor->pixel;
   gcv.background = Tk_3DBorderColor( MBp->bgBorder )->pixel;
   gcv.graphics_exposures = False;
   mask = GCForeground | GCBackground | GCFont | GCGraphicsExposures;
   gc = Tk_GetGC( MBp->tkwin, mask, &gcv );
   if( MBp->gc != NULL ) {
      Tk_FreeGC( MBp->display, MBp->gc );
   }
   MBp->gc = gc;

   /* 描画準備 */
   if( MBp->layout != NULL ) {
      Tk_FreeTextLayout( MBp->layout );
   }
   /* これで表示文字列に関する表示サイズ取得がOK */
   MBp->layout = Tk_ComputeTextLayout( MBp->font, Tcl_GetString(MBp->text),
                              -1, 0, MBp->justify, 0, 
                              &MBp->textWidth, &MBp->textHeight );

   /* MyButton ウィジットのサイズ決定...かなりいい加減 */
   /* 表示すべき文字のサイズから、ウィジットの大きさを決めている */
   Tk_GeometryRequest( MBp->tkwin, MBp->textWidth + 10, MBp->textHeight + 6 );

   /* もしウィジットがリアライズされていて、現在描画処理中でなければ */
   if( Tk_IsMapped(MBp->tkwin) && !MBp->updatePending ) {
      /* アイドルコールバックに実描画をスケジュール */
      Tcl_DoWhenIdle( MyButtonIdle, (ClientData)MBp );
      MBp->updatePending = 1;
   }
}

で問題のアイドルコールバックだ。ここで描画処理を実行する。ダブルバッファリングで描画するのが、やはり定石のようだ。文字列描画もすでに準備してあり(Tcl_Layout)、しかもそれをサポートするAPIがあるので、簡単なものだ。とはいえ、ここでは「マウス状態などに応じた見かけの変化」はまったくサポートしていないので、ちょっと XLibだけで簡単に作ったプログラムみたいな見かけである。勿論これはすぐに修正できるようなものだが、ただでさえ長いこの文書を更に長くはしたくないので、止めておく。「読者への宿題」だな。

/* アイドルコールバック(実質上描画処理) */
void MyButtonIdle( ClientData cd )
{
    MyButton *MBp = (MyButton *)cd;
    Tk_Window tkwin = MBp->tkwin;
    Display *d = Tk_Display(tkwin);
    Pixmap pm;
    GC gc = MBp->gc;
    int x, y;
    /* プロトタイプ in generic/tkIntDecls.h(generic/tkUtil.c) */
    void TkComputeAnchor(Tk_Anchor anchor, Tk_Window tkwin, int padX, int padY,
                      int innerWidth, int innerHeight, int * xPtr, int * yPtr); 
    
    if( tkwin == NULL || !Tk_IsMapped(tkwin) ) {
       printf( "tkwin=%p\n", tkwin );
       return;
    }
    MBp->updatePending = 0;

    /* いわゆるダブルバッファリング */
    pm = XCreatePixmap( d, Tk_WindowId(tkwin), Tk_Width(tkwin), Tk_Height(tkwin),
                   Tk_Depth(tkwin) );
    Tk_Fill3DRectangle( tkwin, pm, MBp->bgBorder, 0, 0, Tk_Width(tkwin),
                   Tk_Height(tkwin), 1, TK_RELIEF_FLAT );
    /* 文字列表示位置の計算(内部関数だったりするので公開プロトタイプがない) */
    TkComputeAnchor( MBp->anchor, tkwin, 0, 0, MBp->textWidth, MBp->textHeight,
                 &x, &y );
    Tk_DrawTextLayout( d, pm, gc, MBp->layout, x, y, 0, -1 );
    /* 仕上げの実描画 */
    XCopyArea( d, pm, Tk_WindowId(tkwin), MBp->gc, 0, 0, Tk_Width(tkwin),
            Tk_Height(tkwin), 0, 0 );
    Tk_FreePixmap( d, pm );
}

「イベントハンドラ」&「削除ハンドラ」である。ここでは本来「マウスがウィジットウィンドウの中に入ったから見かけを変える...」なんていうGUIっぽい処理をすべきであるのだが、手を抜いてある。それでも「ウィンドウの破棄(DestroyNotify)」に応じて確保したいろいろなリソースを破棄する処理とか、「ボタンらしくクリックしたら何かする」処理だけはしてある。「ウィンドウ破棄」はウィンドウベースのアクションで起きる可能性と、プログラムの側の理由で起きる可能性と両方あるので、ここでは「プログラム側でのウィジット破棄」が「ウィンドウイベントとしてウィンドウに伝わる」という前提でプログラムしてある。

/* イベントハンドラ(超手抜き) */
void MyButtonEventProc( ClientData cd, XEvent *event )
{
   MyButton *MBp = (MyButton *) cd;
   if ((event->type == Expose) && (event->xexpose.count == 0)) {
       goto redraw;
   } else if (event->type == ConfigureNotify) {
       goto redraw;
   } else if (event->type == DestroyNotify) {
      /* ウィンドウ破棄 */
      if( MBp->updatePending ) {
         Tcl_CancelIdleCall( MyButtonIdle, (ClientData)MBp );
      }
      Tcl_DeleteCommandFromToken( MBp->interp, MBp->widgetCmd );
      /* リソースの解放 */
      if( MBp->gc != None ) Tk_FreeGC( MBp->display, MBp->gc );
      if( MBp->layout != NULL ) Tk_FreeTextLayout( MBp->layout );
      Tk_FreeConfigOptions( (char *)MBp, MBp->optionTable, MBp->tkwin );
      MBp->tkwin = NULL;
      Tcl_EventuallyFree( (ClientData)MBp, TCL_DYNAMIC );
   } else if( event->type == ButtonRelease ) {
      /* ホントは Enter, Leave などにも対応して、見かけを変えるべきだが、
         長くなるので止め(手抜き) */
      Tcl_EvalObjEx( MBp->interp, MBp->command, TCL_EVAL_GLOBAL );
   }
   return;

   redraw:
   if( (MBp->tkwin != NULL) && (! MBp->updatePending) ) {
       Tk_DoWhenIdle( MyButtonIdle, (ClientData)MBp );
       MBp->updatePending = 1;
   }
}

/* 削除コールバック(実作業はイベントコールバックで) */
void MyButtonDeletedProc( ClientData cd )
{
    MyButton *MBp = (MyButton *)cd;
    if( MBp->tkwin != NULL ) {
       Tk_DestroyWindow( MBp->tkwin );
    }
}

ふう、お疲れ。Tk ウィジットを作るのは面倒だが、上で示したスケルトンを使ってやれば結構簡単にできるんじゃないかと思う。ぜひぜひ活用してくれ(といって、活用できるプログラマがどのくらいいるのかな???)。


C言語の上から Tk をツールキットとして利用する

さて、ちょっとヘヴィだったな...やはり Tk ウィジットを新しく作るのは大変だ。しかし、Tk はオブジェクト指向言語ではないので「継承」ができず、「既存ウィジットにちょっと手を加えて自前のウィジットを作る」というのが難しいんである。これはOusterhautに成り変わって「ゴメン」としか言いようがない。

しかも、作り付けのウィジット類のコールバックは、static で宣言をしていやがる。これは要するに、簡単に Motif とか Athena とかみたいには使えない、ということになるのである。しかし、頭が良ければこれは「トンチ」によって解決は可能だ。要するにC言語のソースの中で、

    sprintf( s, "button .but -text %s\n", argv[1] );
    Tcl_GlobalEval( interp, s );

という具合に Tclスクリプトを文字列のかたちで用意して、それを評価してやることで、C言語の上から Tk ウィジットを使う事は可能なのである。しかし、こんなの紹介しても虚しいので、皆さんには「ヒント」として与えるだけにしよう。

で、ここでは「Tcl からでは出来ないことを、Cプログラムでする」という実用的な例についてやってみよう。それは「画像フィルター処理」だ(一応全然できないわけでもないのだが、インタプリタからやるのは実用的じゃないな)。イメージを適当に読み込んで、マウスで適用範囲を指定して、そこにフィルターをかける、というのはなかなか面白かろう。

これは要するに、フィルターコマンドを Tcl コマンドとして実装するのである。だから簡単である。コマンド名は「filter」とでもしておこう。こういう風に使うことにする。

filter filtername image option....

まあ、画像フィルターなんて考えれば山のようにあるわけだが、ここではサンプルなので「ネガ化」と「明暗変化」だけをサポートする。RGB単位でイジレれば、後のフィルターなんてその要領で簡単に書けることになる。

filter nega image
filter blightness image 変化量

使いかたはこんな風になるな。勿論今度も 8.1 以降でサポートされた、Tcl_Obj で受ける奴で書いてみよう。まずCルーチンの方から。

#include <stdio.h>
#include <stdlib.h>
#include <math.h>
#include <string.h>
#include <tcl.h>
#include <tk.h>


int Filter_Init( Tcl_Interp *interp );
int Filter_Command( ClientData cd, Tcl_Interp *interp, int argc, Tcl_Obj **argv );

int main( int argc, char **argv )
{
   Tcl_Interp *interp;
   char s[100];

   if( argc != 2 ){
      fprintf( stderr, "%s wrong number of argments\n", argv[0]  );
      exit( 1 );
   }

   /* 定型的な Tclコマンド作成 */
   interp = Tcl_CreateInterp();
   if( Tcl_Init( interp ) == TCL_ERROR ){
      fprintf( stderr, "%s\n", interp->result );
      exit( 1 );
   }

   if( Tk_Init( interp ) == TCL_ERROR ){
      fprintf( stderr, "Tk_Init failed:%s\n", interp->result );
      exit( 1 );
   }

   if( Filter_Init( interp ) == TCL_ERROR ){
      fprintf( stderr, "Filter_Init failed:%s\n", interp->result );
      exit( 1 );
   }

   /* argv[1] で渡る画像ファイル名から「original」という image を
      ここで作っておく。これはグローバル変数として扱われる */
   sprintf( s, "image create photo original -file %s\n", argv[1] );
   Tcl_GlobalEval( interp, s );

   Tcl_EvalFile( interp, "./filter.tcl" );
   Tk_MainLoop();
   return( 0 );
}

int Filter_Init( Tcl_Interp *interp )
{
   Tcl_CreateObjCommand( interp, "filter", (Tcl_ObjCmdProc *)Filter_Command, 
                    (ClientData *)NULL, (Tcl_CmdDeleteProc *)NULL );
   return( TCL_OK );
}

はっきり言って、ウィジットコマンド以外は超簡単だ。こんなのもう説明の必要もないくらいだ。で、ウィジットコマンドでは、Tk の image を引数の名前から検索して...とかいろいろと処理がある。

まあ、きっと皆さん御存じのこととは思うが、画像はRGBである。要するに赤、緑、青の色要素が 1pixel に対してあるわけで、それらはフツー1byteづつ使って 1pixel につき 3byte 必要になる。が、3byte というのはキリが悪いので、よく 4byte で処理をする、ということも多分御存じだろう。Tk のデフォルト画像バッファもこうなっている。だから、フィルター処理をするのはこんな流れだ。

  1. 引数で渡るオリジナルの名前からその「画像ハンドル」を検索して取得
  2. 「画像ハンドル」から「画像バッファ」を取得
  3. 新たに「作業用バッファ」を必要な分だけ確保する
  4. そこにpixelに対応するように RGBをバラして再計算したものをセットしてやる。
  5. 「作業用バッファ」を本来の「画像ハンドル」に結びつけてやる

こんな手順である。だから、pixelに対応するようにRGBをバラすのは、マクロを書いてやるのが良いだろうから、そうしてある。まあ、マクロの定義はここらへんを見てから理解した方がよいだろうが....

/* マクロで個々のピクセル(RGB)にアクセスすることにする */
#define RED(p,x,y)      ((p)->pixelPtr[(y)*(p)->pitch+(x)*(p)->pixelSize + (p)->offset[0]])
#define GREEN(p,x,y)    ((p)->pixelPtr[(y)*(p)->pitch+(x)*(p)->pixelSize + (p)->offset[1]])
#define BLUE(p,x,y)     ((p)->pixelPtr[(y)*(p)->pitch+(x)*(p)->pixelSize + (p)->offset[2]])

/* 用意されたフィルター(ネガ化)*/
void change_nega( Tk_PhotoImageBlock *oldib, Tk_PhotoImageBlock *newib, 
                  int tx, int ty )
{
   int x, y;

   for( y = 0; y < ty; y++ ){
      for( x = 0; x < tx; x++ ){
         RED( newib, x, y ) = 255 - RED( oldib, x, y );
         GREEN( newib, x, y ) = 255 - GREEN( oldib, x, y );
         BLUE( newib, x, y ) = 255 - BLUE( oldib, x, y );
      }
   }
}

/* 用意されたフィルター(明暗変更)*/
void change_blightness( Tk_PhotoImageBlock *oldib, Tk_PhotoImageBlock *newib, 
                        int tx, int ty, int val )
{
   int x, y;

   for( y = 0; y < ty; y++ ){
      for( x = 0; x < tx; x++ ){
         int r = RED( oldib, x, y ) + val;
         int g = GREEN( oldib, x, y ) + val;
         int b = BLUE( oldib, x, y ) + val;
         r = (r>255)?255:r; r = (r<0)?0:r;
         g = (g>255)?255:g; g = (g<0)?0:g;
         b = (b>255)?255:b; b = (b<0)?0:b;
         RED( newib, x, y ) = r;
         GREEN( newib, x, y ) = g;
         BLUE( newib, x, y ) = b;
      }
   }
}

/* さて、ウィジットコマンドのコールバック関数 */
int Filter_Command( ClientData cd, Tcl_Interp *interp, int argc, Tcl_Obj **argv )
{
   Tk_PhotoHandle photo; /* 画像ハンドル */
   Tk_PhotoImageBlock oldib, newib;  /* 実際の画像データ */
   int tx, ty;  /* 画像幅・高さ */
   char *kind;  /* フィルター種別 */

   if( argc < 3 ) {
      Tcl_WrongNumArgs( interp, 1, argv, "filtername image ?options?" );
      return TCL_ERROR;
   }
   /* 画像ハンドルの取得 */
   photo = Tk_FindPhoto( interp, Tcl_GetString(argv[2]) );
   kind = Tcl_GetString(argv[1]);

   /* オリジナル画像データの取得(幅、高さ、画像バッファ) */
   Tk_PhotoGetSize( photo, &tx, &ty );
   Tk_PhotoGetImage( photo, &oldib );

   /* 新しく作る画像バッファ(フィルター後のイメージ・カラー) */
   newib.width = tx;
   newib.height = ty;
   newib.pixelSize = 4;  /* 1pixel に対して4bit(RGBA)使う */
   newib.pitch = tx * 4; /* とすると、1列のバイト数がこうなる */
   newib.offset[0] = 0;  /* 赤の色データのオフセット */
   newib.offset[1] = 1;  /* 緑の色データのオフセット */
   newib.offset[2] = 2;  /* 青の色データのオフセット */
   /* 必要サイズ分を確保する */
   newib.pixelPtr = (unsigned char *)malloc( tx * ty * 4 );
   if( newib.pixelPtr == NULL ){
      interp->result = "Error in memory allocation";
      return TCL_ERROR;
   }
   memset( newib.pixelPtr, 0, tx * ty * 4 );

   /* フィルター種別による場合わけ */
   if( strcmp( kind, "nega" ) == 0 ) {
      change_nega( &oldib, &newib, tx, ty );
   } else if( strcmp( kind, "blightness" ) == 0 ) {
      int value;
      if( argc != 4 ) {
         Tcl_WrongNumArgs( interp, 1, argv, "blighness image value" );
         free( newib.pixelPtr );
         return TCL_ERROR;
      }
      /* 第4引数から明暗変化値を取得 */
      Tcl_GetIntFromObj( interp, argv[3], &value );
      change_blightness( &oldib, &newib, tx, ty, value );
   } else {
      char buff[256];
      sprintf( buff, "no such command ?filter %s?", kind );
      Tcl_AddErrorInfo( interp, buff );
      free( newib.pixelPtr );
      return TCL_ERROR;
   }
   /* 画像にフィルターをかけた後のイメージをセット */
   Tk_PhotoPutBlock( photo, &newib, 0, 0, tx, ty );
   /* 作業に使った画像バッファを解放 */
   free( newib.pixelPtr );
   return( TCL_OK );
}

まあ、そんなに大したコードではないな。じゃ、これを使う tcl コマンドのファイルはこんなところか。

# 汎用フィルター画像エディタ
# すでに「original」という名前で引数で与えられた画像がシンボル化されている
# 画像の高さ幅の取得
set tx [image width original]
set ty [image height original]

# -1 した幅高さを作っておく
set tx1 [expr $tx -1]
set ty1 [expr $ty -1]

# マウスで選択された位置の初期化
set cor1 {0 0}
set cor2 [list [expr $tx1] [expr $ty1]]

# ウィジット製作
canvas .c -bd 2 -relief raised -width $tx -height $ty -scrollregion "0 0 $tx1 $ty1"
frame .but -bd 2 -relief flat
button .but.bye -text "Bye" -command "exit"
button .but.sav -text "Save" -command "original write result.ppm -format PPM"
button .but.nega -text "Nega" -command "dofilter nega"
button .but.blighter -text "Blighter" -command "dofilter blighter"
button .but.darker -text "Darker" -command "dofilter darker"

pack .c .but -side top -expand yes -fill x
pack .but.bye .but.sav .but.nega .but.blighter .but.darker -side left -expand yes -fill x

.c create image 0 0 -anchor nw -image original -tags "image"

# マウスイベントに対する bind
bind .c <Button-1> "firstcorner %x %y"
bind .c <B1-Motion> "moving %x %y"
bind .c <ButtonRelease-1> "secondcorner %x %y"
bind .c <Button-2> "clearrec"

# マウスを押した時に呼び出される
proc firstcorner {xm ym} {
   global cor1
   # Canvasウィジットに対する位置で再計算して保存
   set cor1 [list [.c canvasx $xm] [.c canvasy $ym]]
   .c delete selrec
}

# マウスをドラッグしている時に呼び出される
proc moving {xm ym} {
   global cor1 cor2 tx ty

   set x [.c canvasx $xm]
   set y [.c canvasy $ym]

   if { $x >= 0 && $x < $tx && $y >= 0 && $y < $ty } {
      # ドラッグされた時に「ラバーバンド」を描画
      .c delete selrec
      .c create rectangle [lindex $cor1 0] [lindex $cor1 1] \
            $x $y -outline yellow -tags selrec
      set cor2 [list $x $y]
   }
}

# マウスボタンを離した時に呼び出される
proc secondcorner {xm ym} {
   global cor1 cor2 tx ty

   set x [.c canvasx $xm]
   set y [.c canvasy $ym]

   if { $x >= 0 && $x < $tx && $y >= 0 && $y < $ty } {
      .c delete selrec
      set cor2 [list $x $y]
      # ラバーバンドの描画。これで選択範囲が確定
      .c create rectangle [lindex $cor1 0] [lindex $cor1 1] \
            $x $y -outline yellow -tags selrec
   }
}

# 選択解除
proc clearrec { } {
   global cor1 cor2 tx1 ty1

   .c delete selrec
   set cor1 [list 0 0]
   set cor2 [list $tx1 $ty1]
}

# さて、フィルターを実行する
proc dofilter { kind } {
   global cor1 cor2

   # 選択範囲を取得する。整数値に直しておく
   set p1x [expr round([lindex $cor1 0])]
   set p1y [expr round([lindex $cor1 1])]
   set p2x [expr round([lindex $cor2 0])]
   set p2y [expr round([lindex $cor2 1])]

   # 念のために大小関係で swap する
   if { $p1x > $p2x } { set tmp $p2x; set p2x $p1x; set p1x $tmp }
   if { $p1y > $p2y } { set tmp $p2y; set p2y $p1y; set p1y $tmp }

   incr p2x; incr p2y

   # 選択範囲からイメージを切り出す
   image create photo tmpimg
   tmpimg copy original -from $p1x $p1y $p2x $p2y

   # 切り出されたイメージに対してフィルターを適用
   if { $kind == "nega" } {
      filter nega tmpimg
   } elseif { $kind == "blighter" } {
      filter blightness tmpimg 10
   } elseif { $kind == "darker" } {
      filter blightness tmpimg -10
   } else {
      puts "illegal command filter $kind"
      return
   }
   # Cルーチンで変更されたイメージを、オリジナル画像に転写
   original copy tmpimg -to $p1x $p1y
   # 後始末
   image delete tmpimg
   .c delete selrec
}

他のスクリプト言語のGUIライブラリから利用する

さて、最後は Tk ウィジットを他の言語から呼び出されるライブラリとして使う例だ。ここでは Perl から Tk ウィジットを利用するためのライブラリである、Perl/Tk を使ってみよう。Perl/Tk は例によって CPAN でも覗いて貰えれば見つかることと思う。「Tkバージョン.tar.gz」みたいなファイル名だ。

これはご苦労なことに、共有ライブラリ使いではない。そうじゃなくて Tk の仕様に沿って、フルスクラッチで書かれたライブラリだったりする....こんなんメンテが大変だろうな。だから多分既にインストールしている Tk ライブラリには全然依存しないので、インストールは楽だ。単に CPAN モジュールの定型に従って、「perl Makefile.PL; make; make install」で済んでしまう。

で、やってみるのは以前見た、「URLを入れてHTMLを取得して、リンクだけを抽出してリストにする」という奴だ。今回のネライは実は、どうせ Perl でやるんだから、LWP でも使っちゃおうか、という点にある。どうせGUIは以前 Tcl/Tk で書いた奴をかなり機械的に直していくだけだ。あまり面白くないので、同じく CPAN にあって、よく使われているライブラリのひとつである LWP を使って、あの時にはCで書いた(というかCで Tcl コマンドを作成した)HTTPアクセスを安直に実現しよう、というのがネライである。

LWP はどうやら「Lib WWW for Perl」あたりの略のようだ。これはWWWサービスに対するアクセスを Perl の上で実現するライブラリで、結構安易にロボットが書けちゃうものだ。特に LWP::RobotUA モジュールなんかを使えば、ちゃんと robots.txt を呼んで紳士的に振る舞うロボットが簡単に手に入る。しかもHTMLをパースしてリンクをひきずり出して...といった面倒な処理がちゃんとライブラリ化されている、というスグレ物ライブラリだ。

ただし、ちぃとばかし敷居が高いのは、結構いろいろと CPAN からライブラリを落としてこないと使えない...ということである。最近のディストリビューションだと多少 LWP 関連ライブラリが既に入っているようだが、ちゃんと使うには遠い。まあ、こんなくらいのモジュールが必要のようだ。

MIME-Base64-x.xx(MIME::Base64)
Digest-x.xx(Digest::Base)
Digest-MD5-x.xx(Digest::MD5)
HTML-Parser-x.xx(HTML::Parser で使う下位モジュール)
HTML-Tagset-x.xx(HTML::Tagset)
HTML-Tree-x.xx(HTML::Parser)
uri-x.xx(URI::URL)
libnet-x.xx(Net::FTP...今回は使わないが、一応パッケージが依存する)
libwww-perl-x.xx(LWP::RobotUA など)

運がよければ、このうちいくつかは既に /usr/lib/perl5(とか)以下に入っているかもしれない。まあ、確認してから落とすのが良かろう。一般にこいつらのインストールは楽だ。定石どおりやればOK。

LWPには基本的にロボットを作るためのライブラリ一式が揃っている。まあ、これは使うだけのものなのだが、当然前回はサボったプロキシ対応なんかもちゃんとやっている。まずはその部分だが、一応「簡単な奴」と「面倒な奴」の2通りのインターフェイスがある。「簡単な奴」は LWP::Simple で、基本的にローカルなWWWサーバから単にHTMLをひきずり出すためのもので、「面倒な奴」は LWP::RobotUA で「ロボット規約」に沿った本格的ロボットの実装である(遅いのが難)。ちょっとテストするのだと、両方揃っていて選択できるようにしておいた方がプログラムとしては無難であるので、そうしている。どっちを使うかは「$mode」で指定できるようにしておこう。

#!/usr/bin/perl

# Perl/Tk ライブラリ
use Tk;

# LWP ライブラリ
use LWP::Simple;
use LWP::RobotUA;
use HTTP::Request;
use HTTP::Response;
use HTML::Parse;
use HTML::Element;
use URI::URL;

my($URL,$delHeader);

# 「面倒な奴」は "robot", 「簡単な奴」は "simple"
$mode = "robot";

# ロボットが名乗る名前
$RobotName = "SugiuraWebbot";
# ロボットが自分の連絡先として使うメアド
$MailAddress = "kojisug@kobe-du.ac.jp";
# プロキシのURL
$Proxy = "http://133.32.201.1:8080/";
# プロキシを使わないローカルのURLのリスト
@noProxies = ( 'localhost', 'kobe-du.ac.jp', 'www.nurs.or.jp' );

# LWP を使って URL から HTML をひきずりだす
sub access_html {
   my ($url,$mode) = @_;
   if( $mode eq "simple" ) {
     # 「簡単な奴」
     $html = LWP::Simple::get $url;
     return $html;
   } else {
     # 「面倒な奴」
     $ua = new LWP::RobotUA( $RobotName, $MailAddress );
     # プロキシの設定
     $ua->proxy( 'http', $Proxy );
     $ua->no_proxy( @noProxies );
     # リクエストの発行
     $req = new HTTP::Request( 'GET', $url );
     # レスポンスの取得
     $res = $ua->request( $req );
     if( $res->is_success ) {
       return $res->content;
     } else {
       return "";
     }
   }
}

# 相対URLを絶対URLへ変換する
sub normalize {
   local( $url, $parentdir ) = @_;
   local( $thisurl, $full, $frag, $query );
   $thisurl = new URI::URL $url;
   $full = $thisurl->abs($parentdir);
   $frag = $thisurl->frag;
   # クエリとかフラグメントは外す
   $full =~ s/#.*$//;
   $query = $thisurl->equery;
   $full =~ s/\?.*$//;
   return $full;
}

# 引き出したリンク先をソートしてユニークする
sub sortuniq {
   my(@lis) = @_;
   local( @ret, $prev );
   @lis = sort @lis;
   @ret = (); $prev = "";
   foreach( @lis ) {
     if( $_ ne $prev ) {
       @ret = (@ret, $_ );
       $prev = $_;
     }
   }
   return @ret;
}

で、次はGUIからこのLWPを使い倒すユーザインターフェイスの部分になる。本題の Perl/Tk の部分だ。Perl/Tk は大体素直に Tk コマンドを Perlパッケージ使いのエセOOP言語風構文で使えるようにしている。こんなんTkが判ってりゃ見りゃ判る...風のものだが、それでもウィジットだけはちょっと整理しておこう。名前は以前の Tcl/Tk 版と対応させている。

$text
ひきずり出したテキストを表示する Text ウィジット
$scroll1
$textウィジットに付くスクロールバー
$list
抽出したリンクを並べる Listウィジット
$scroll2
$listウィジットに付くスクロールバー
$mw
Tcl/Tk版にはないトップウィンドウ
$l1,$l2,$l3
配置するための Frame ウィジット

それでもサブルーチンから。

# 指定された $url から取得して内容を $text ウィジットに表示し、
# 抽出されたリンクを $list ウィジットに表示する。
sub readURL {
   my ($url) = @_;
   local( $html, $phtml, $full );
   local( @links );

   # $text, $list ウィジットを空にする
   $text->delete( '1.0','end' );
   $list->delete( '0', 'end' );

   # リンクリストを空に初期化
   @links = ();

   # $url から内容を取得する
   $html = &access_html($url,$mode);

   # 結果が空(エラー)ならその旨を表示して終わる
   if( $html eq "" ) {
     $text->insert( 'end', "cannot find $url\n" );
     return -1;
   }

   # 表示のため \r は消して $text に入れる
   $html =~ s/\r//g;
   $text->insert( 'end', $html );

   # HTML をパースする
   $phtml = HTML::Parse::parse_html($html);

   # extract-links() でリンクだけを抽出してループで回す
   for (@ { $phtml->extract_links() } ) {
     # 相対URLを絶対URLに直す
     $full = &normalize( $_->[0], $url );
     if( $full =~ /^http/ ) {
       # 多分 HTML のリンクであるものだけに絞ってリンクリストに追加
       if( $full =~ /\.html$/ || $full =~ /\.htm$/
            || $full =~ /\.shtml$/ || $full =~ m|/$| ) {
         @links = (@links, $full );
       }
     }
   }
   # ダブリを消去してソートし、
   @links = &sortuniq( @links );
   # $list に追加する。
   foreach (@links) {
     $list->insert( 'end', $_ );
   }
}

# $list(抽出リンクリスト)のクリックのコールバック
sub jumpURL {
   # 現在のセレクションを取得する
   $URL = $list->get( $list->curselection );
   &readURL( $URL );
}

で、いかにも Perl/Tk らしいメインルーチンだ。Tcl/Tk と違って、まず $mw というメインウィンドウを new で用意する必要があるあたり、OOP臭い仕様だ。で、Tcl/Tk ではいちいちウィジットコマンドで .l1.button のようなウィジットを作ったが、Perl/Tk ではこれを無名にしてしまって構わない。ウィジットの親子関係はたとえば Frameウィジットである $l1 に対して、

$l1->Button();

のようなかたちで無名で作ることができるのである。あと、Tk のさまざまなオプションは、どうせ Perl だと連想配列のかたちで渡すことになるので、「-text=>'GO'」のようなかたちで指定できる。この時、-command オプションのようなコールバック指定は、ちょっとした便法で「sub{ &callback }」のように一時的に無名のサブルーチンを作ってその中で呼び出すようにする。また、ウィジットの pack は、生成時にいっしょにやってしまうのが、Perl/Tk らしい書き方だ。

$l1->Button( -text=>'GO',-command=>sub {&readURL($URL)} )->pack( -side=>'left' );

だが、こういう冗長な書き方でもよい。

$but = $l1->Button( -text=>'GO',-command=>sub {&readURL($URL)} );
$but->pack( -side=>'left' );

これが結果的に Tcl/Tk の

button .go -text "GO" -command { readURL $URL }
pack .go -in .l1 -side left

に対応するのである。じゃ、コードだ。→Tcl/Tk版の対応箇所

# メインウィンドウ
$mw = MainWindow->new;
# 最初の行グループ
$l1 = $mw->Frame()->pack( -side=>'top' );
$l1->Label( -text=>'URL:' )->pack( -side=>'left' );
$l1->Entry( -width=>30,-textvariable=>\$URL )->pack( -side=>'left' );
$l1->Button( -text=>'GO',-command=>sub {&readURL($URL)} )->pack( -side=>'left' );

$mw->Label( -text=>"Got File" )->pack( -side=>'top' );

# 2つめの行グループがテキスト表示(スクロールバー付き)
$l2 = $mw->Frame()->pack( -side=>'top' );
$scroll1 = $l2->Scrollbar;
$text = $l2->Text( -yscrollcommand=> ['set', $scroll1], -wrap=>'char' );
$scroll1->configure( -command=>['yview',$text]);
$scroll1->pack(-side=>'right',-fill=>'y');
$text->pack(-side=>'top',-fill=>'both',-expand=>'yes');

$mw->Label( -text=>"Links in the file" )->pack( -side=>'top' );

# 3つめの行グループが抽出リンクリスト(スクロールバー付き)
$l3 = $mw->Frame()->pack( -side=>'top' );
$scroll2 = $l3->Scrollbar;
$list = $l3->Listbox( -yscrollcommand=> ['set', $scroll2], -width=>50 );
# コールバック登録
$list->bind( '<Double-Button-1>', sub { &jumpURL } );
$scroll2->configure( -command=>['yview',$list]);
$scroll2->pack(-side=>'right',-fill=>'y');
$list->pack(-side=>'top',-fill=>'both',-expand=>'yes');

# 終了ボタン
$mw->Button( -text=>'Quit',-command=>sub {exit 0} )->pack(-side=>'bottom');

# メインループの呼び出し(絶対的必須!)
MainLoop;

大体 Tcl/Tk 版の機械的書き換えで済む、という見当が付くことと思う。だからこれも Tcl/Tk が判ってりゃ、へいちゃらだ。



copyright by K.Sugiura, 1996-2006