M.Hiroi's Home Page

Tcl/Tk GUI Programming

Tcl/Tk お気楽 GUI プログラミング実用編

[ Home | Tcl/Tk | Tcl/Tk入門 ]

●Tcl/Tk とＣ言語

●Tcl インタプリタと Tcl オブジェクト

リスト : Ｃ言語から Tcl インタプリタを呼び出す (sample01.c)

#include <stdio.h>
#include <tcl/tcl.h>  /* Cygwin は #include <tcl.h> とする */ 

#define BUFF_SIZE 1024

int main()
{
  char buff[BUFF_SIZE];
  Tcl_Interp *ip = Tcl_CreateInterp();

  printf("> ");
  while (fgets(buff, BUFF_SIZE, stdin) != NULL) {
    if (Tcl_Eval(ip, buff) != TCL_OK) {
      fprintf(stderr, "%s\n", Tcl_GetStringResult(ip));
    } else {
      printf("%s\n", Tcl_GetStringResult(ip));
    }
    printf("> ");
  }

  Tcl_DeleteInterp(ip);
  return 0;
}

$ gcc -O sample01.c -o sample01 -ltcl
$ ./sample01
> set a 10
10
> set b
can't read "b": no such variable
> set b 20
20
> expr $a + $b
30
> CTRL-D で終了

●Tcl コマンドの作成

リスト : Tcl コマンドの作成 (sample02.c)

#include <stdio.h>
#include <string.h>
#include <tcl/tcl.h>

#define BUFF_SIZE 1024

/* コマンド */
static int proc_foo(ClientData clientData, Tcl_Interp *ip, int argc, Tcl_Obj *const argv[])
{
  char *err = "wrong # args: should be \"foo arg1 arg2 ...\"";
  if (argc < 3) {
    Tcl_SetObjResult(ip, Tcl_NewStringObj(err, strlen(err)));
    return TCL_ERROR;
  }
  for (int i = 0; i < argc; i++) {
    int len;
    printf("%s ", Tcl_GetStringFromObj(argv[i], &len));
  }
  printf("\n");
  Tcl_SetObjResult(ip, Tcl_NewIntObj(argc));
  return TCL_OK;
}

int main()
{
  char buff[BUFF_SIZE];
  Tcl_Interp *ip = Tcl_CreateInterp();

  /* コマンドの登録 */
  Tcl_CreateObjCommand(ip, "foo", proc_foo, NULL, NULL);

  printf("> ");
  while (fgets(buff, BUFF_SIZE, stdin) != NULL) {
    if (Tcl_Eval(ip, buff) != TCL_OK) {
      fprintf(stderr, "%s\n", Tcl_GetStringResult(ip));
    } else {
      printf("%s\n", Tcl_GetStringResult(ip));
    }
    printf("> ");
  }

  Tcl_DeleteInterp(ip);
  return 0;
}

$ gcc -O sample02.c -o sample02 -ltcl
$ ./sample02
> foo
wrong # args: should be "foo arg1 arg2 ..."
> foo 1 2
foo 1 2
3
> foo 1 2 3 4
foo 1 2 3 4
5
>

●パッケージの作成

リスト : パッケージの作成 (libfoo.c)

#include <tcl.h>
#include <string.h>

/* コマンド */
int proc_foo(ClientData clientData, Tcl_Interp *ip, int argc, Tcl_Obj *const argv[])
{
  char *err = "wrong # args: should be \"foo arg1 arg2 ...\"";
  if (argc < 3) {
    Tcl_SetObjResult(ip, Tcl_NewStringObj(err, strlen(err)));
    return TCL_ERROR;
  }
  for (int i = 0; i < argc; i++) {
    int len;
    printf("%s ", Tcl_GetStringFromObj(argv[i], &len));
  }
  printf("\n");
  Tcl_SetObjResult(ip, Tcl_NewIntObj(argc));
  return TCL_OK;
}

/* Tcl コマンドの初期化 */
int Foo_Init(Tcl_Interp *ip)
{
  Tcl_CreateObjCommand(ip, "foo", proc_foo, NULL, NULL);
  return Tcl_PkgProvide(ip, "foo", "1.0");
}

●名前空間

リスト : 名前空間の使用例

#include <tcl/tcl.h>
#include <string.h>

/* コマンド */
int proc_foo(ClientData clientData, Tcl_Interp *ip, int argc, Tcl_Obj *const argv[])
{
  char *err = "wrong # args: should be \"foo::foo arg1 arg2 ...\"";
  if (argc < 3) {
    Tcl_SetObjResult(ip, Tcl_NewStringObj(err, strlen(err)));
    return TCL_ERROR;
  }
  for (int i = 0; i < argc; i++) {
    int len;
    printf("%s ", Tcl_GetStringFromObj(argv[i], &len));
  }
  printf("\n");
  Tcl_SetObjResult(ip, Tcl_NewIntObj(argc));
  return TCL_OK;
}

/* Tcl コマンドの初期化 */
int Foo_Init(Tcl_Interp *ip)
{
  Tcl_Namespace *np = Tcl_CreateNamespace(ip, "foo", NULL, NULL);
  Tcl_CreateObjCommand(ip, "foo::foo", proc_foo, NULL, NULL);
  Tcl_Export(ip, np, "foo", 0);
  return Tcl_PkgProvide(ip, "foo", "1.0");
}

$ gcc -O -shared -fPIC -o libfoo.so libfoo.c -ltcl
$ tclsh
% load libfoo.so
% foo::foo 1 2 3
foo::foo 1 2 3 
4
% foo 1 2 3
invalid command name "foo"
% namespace import foo::*
% foo 1 2 3
foo 1 2 3 
4
%

●リスト

リスト : リスト操作関数の使用例 (mylist.c)

#include <tcl/tcl.h>
#include <string.h>

/* リストの生成 (コマンド list と同じ) */
int proc_mylist(ClientData clientData, Tcl_Interp *ip, int argc, Tcl_Obj *const argv[])
{
  Tcl_SetObjResult(ip, Tcl_NewListObj(argc - 1, argv + 1));
  return TCL_OK;
}

/* 数列の生成 */
int proc_iota(ClientData clientData, Tcl_Interp *ip, int argc, Tcl_Obj *const argv[])
{
  int n, c;
  char *err = "wrong # args: should be \"iota start count\"";
  if (argc < 3 ||
      Tcl_GetIntFromObj(ip, argv[1], &n) != TCL_OK ||
      Tcl_GetIntFromObj(ip, argv[2], &c) != TCL_OK) {
    Tcl_SetObjResult(ip, Tcl_NewStringObj(err, strlen(err)));
    return TCL_ERROR;
  }
  Tcl_Obj *xs = Tcl_NewListObj(0, NULL);   /* 空リスト */
  while (c-- > 0) {
    Tcl_ListObjAppendElement(ip, xs, Tcl_NewIntObj(n++));
  }
  Tcl_SetObjResult(ip, xs);
  return TCL_OK;
}

/* 2 つのリストを連想リスト (alist) にまとめる */
int proc_zip(ClientData clientData, Tcl_Interp *ip, int argc, Tcl_Obj *const argv[])
{
  int xlen, ylen;
  char *err = "wrong # args: should be \"zip xs ys\"";
  if (argc != 3) {
    Tcl_SetObjResult(ip, Tcl_NewStringObj(err, strlen(err)));
    return TCL_ERROR;
  }
  Tcl_ListObjLength(ip, argv[1], &xlen);
  Tcl_ListObjLength(ip, argv[2], &ylen);
  if (xlen > ylen) xlen = ylen;

  int i;
  Tcl_Obj *buff[2];
  Tcl_Obj *zs = Tcl_NewListObj(0, NULL);  /* 空リスト */
  for (i = 0; i < xlen; i++) {
    Tcl_ListObjIndex(ip, argv[1], i, buff);
    Tcl_ListObjIndex(ip, argv[2], i, buff + 1);
    Tcl_ListObjAppendElement(ip, zs, Tcl_NewListObj(2, buff));
  }
  Tcl_SetObjResult(ip, zs);
  return TCL_OK;
}

/* 連想リスト (alist) を 2 つのリストに分解する */
int proc_unzip(ClientData clientData, Tcl_Interp *ip, int argc, Tcl_Obj *const argv[])
{
  int len;
  char *err = "wrong # args: should be \"unzip alist\"";
  if (argc != 2) {
    Tcl_SetObjResult(ip, Tcl_NewStringObj(err, strlen(err)));
    return TCL_ERROR;
  }
  Tcl_ListObjLength(ip, argv[1], &len);

  Tcl_Obj *buff[2];
  buff[0] = Tcl_NewListObj(0, NULL);
  buff[1] = Tcl_NewListObj(0, NULL);
  int i;
  for (i = 0; i < len; i++) {
    int k;
    Tcl_Obj *zs[3];
    Tcl_ListObjIndex(ip, argv[1], i, zs);
    Tcl_ListObjLength(ip, zs[0], &k);
    if (k != 2) {
      Tcl_SetObjResult(ip, Tcl_NewStringObj(err, strlen(err)));
      return TCL_ERROR;
    }
    Tcl_ListObjIndex(ip, zs[0], 0, zs + 1);
    Tcl_ListObjIndex(ip, zs[0], 1, zs + 2);
    Tcl_ListObjAppendElement(ip, buff[0], zs[1]);
    Tcl_ListObjAppendElement(ip, buff[1], zs[2]);
  }
  Tcl_SetObjResult(ip, Tcl_NewListObj(2, buff));
  return TCL_OK;
}

int Mylist_Init(Tcl_Interp *ip)
{
  Tcl_CreateObjCommand(ip, "mylist", proc_mylist, NULL, NULL);
  Tcl_CreateObjCommand(ip, "iota", proc_iota, NULL, NULL);
  Tcl_CreateObjCommand(ip, "zip", proc_zip, NULL, NULL);
  Tcl_CreateObjCommand(ip, "unzip", proc_unzip, NULL, NULL);
  return Tcl_PkgProvide(ip, "mylist", "1.0");
}

$ gcc -O -shared -fPIC -o libmylist.so mylist.c -ltcl
$ tclsh
% load libmylist.so
% mylist 1 2 3 4
1 2 3 4
% mylist {1 2} {3 4}
{1 2} {3 4}
% mylist
% iota
wrong # args: should be "iota start count"
% iota a b
wrong # args: should be "iota start count"
% iota 1 10
1 2 3 4 5 6 7 8 9 10
% zip
wrong # args: should be "zip xs ys"
% zip {1 2 3 4} {5 6 7 8}
{1 5} {2 6} {3 7} {4 8}
% set a [zip [iota 1 5] [iota 11 15]]
{1 11} {2 12} {3 13} {4 14} {5 15}
% unzip
wrong # args: should be "unzip alist"
% unzip $a
{1 2 3 4 5} {11 12 13 14 15}
%

●Tcl 変数のアクセス

リスト : グローバル変数専用アクセス関数 (gset.c)

#include <tcl/tcl.h>
#include <string.h>

/* グローバル変数専用版 */
int proc_gset(ClientData clientData, Tcl_Interp *ip, int argc, Tcl_Obj *const argv[])
{
  char *err = "wrong # args: should be \"gset varName ?value?\"";
  if (argc < 2 || argc > 3) {
    Tcl_SetObjResult(ip, Tcl_NewStringObj(err, strlen(err)));
    return TCL_ERROR;
  }
  int len;
  char *name = Tcl_GetStringFromObj(argv[1], &len);
  if (argc == 2) {
    Tcl_Obj *var = Tcl_GetVar2Ex(ip, name, NULL, TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG);
    if (var == NULL) {
      return TCL_ERROR;
    } else {
      Tcl_SetObjResult(ip, var);
    }
  } else {
    if (Tcl_SetVar2Ex(ip, name, NULL, argv[2], TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
      return TCL_ERROR;
    }
  }
  return TCL_OK;
}

int Gset_Init(Tcl_Interp *ip)
{
  Tcl_CreateObjCommand(ip, "gset", proc_gset, NULL, NULL);
  return Tcl_PkgProvide(ip, "gset", "1.0");
}

$ gcc -O -shared -fPIC -o libgset.so gset.c -ltcl
$ tclsh
% load libgset.so
% gset
wrong # args: should be "gset varName ?value?"
% gset a
can't read "a": no such variable
% gset a 1
% gset a
1
% proc foo {} {
set a 10
puts $a
gset a 100
puts [gset a]
puts $a
}
% foo
10
100
10
% gset a
100
Copyright (C) 2019 Makoto Hiroi
All rights reserved.
[ Home | Tcl/Tk | Tcl/Tk入門 ]