tcl_curses
A package created as a part of an effort to create Tcl bindings that work with SNMP. Send a help line to the mailserver for details of signing up for the SNMP Tcl mailing list. Contact the mailing list to ask for details about tcl_curses.
AMG: For the sake of curiosity, and because the source consists of a single file, I took the liberty of mirroring it directly on the Wiki. Also I tidied the style for consistency and readability. It still represents a very old style of Tcl coding which long predates object commands. Here, have a look:
/* curses.c * CURSES interface for TcL * * Poul-Henning Kamp, [email protected] * 920318 0.00 * 920319 0.01 * 920819 0.02 -- NJT */ #include <curses.h> #include "tcl.h" #include "tclHash.h" static char *TraceDebug(); static int CursesProc(); static int WinProc(); typedef struct { int debug; int nl, cbreak, raw, echo; WINDOW *stdscr; } t_cldat; typedef struct { t_cldat *cd; int wbox; WINDOW *win; WINDOW *border; } t_cldat2; void curses_init(Tcl_Interp *interp) { t_cldat *cd; cd = (t_cldat *)ckalloc(sizeof *cd); memset(cd, 0, sizeof *cd); Tcl_CreateCommand(interp, "curses", CursesProc, cd, 0); Tcl_SetVar(interp, "curses_debug", "0", 0); Tcl_TraceVar(interp, "curses_debug", TCL_TRACE_WRITES | TCL_TRACE_UNSETS, TraceDebug, cd); } static int Error(Tcl_Interp *interp, char *win, char *where) { Tcl_AddErrorInfo(interp, "curses "); Tcl_AddErrorInfo(interp, win); Tcl_AddErrorInfo(interp, " "); Tcl_AddErrorInfo(interp, where); Tcl_AddErrorInfo(interp, ": failed"); return TCL_ERROR; } static char * TraceDebug(t_cldat *cd, Tcl_Interp *interp, char *name1, char *name2, int flags) { cd->debug = 0; if (flags & TCL_TRACE_WRITES) { cd->debug = atoi(Tcl_GetVar(interp, "curses_debug", flags&TCL_GLOBAL_ONLY)); } if (flags & TCL_TRACE_UNSETS) { Tcl_SetVar(interp, "curses_debug", "0", flags&TCL_GLOBAL_ONLY); } if (flags & TCL_TRACE_DESTROYED) { Tcl_TraceVar(interp, "curses_debug", TCL_TRACE_WRITES | TCL_TRACE_UNSETS, TraceDebug, cd); } fprintf(stderr, "CURSES: debug is now %d\n", cd->debug); return 0; } static int CursesProc(t_cldat *cd, Tcl_Interp *interp, int argc, char **argv) { int i; Tcl_HashEntry *he; t_cldat2 *cd2; if (cd->debug) { fprintf(stderr, "CURSES: CursesProc %d ", argc); for (i = 0; i < argc; ++i) { fprintf(stderr, "{%s} ", argv[i]); } fprintf(stderr, "\n"); } if (!cd->stdscr) { /* Not yet initscr */ /*XX curses initscr */ if (argc == 2 && !strcmp(argv[1], "initscr")) { WINDOW *w; w = initscr(); if (!w) { return Error(interp, "<none>", argv[1]); } cd2 = (t_cldat2 *)ckalloc(sizeof *cd2); memset(cd2, 0, sizeof *cd2); cd2->cd = cd; cd2->win = w; cd2->border = NULL; cd2->wbox = 0; cd->stdscr = cd2->win; cd->nl = 1; cd->cbreak = 0; cd->echo = 1; cd->raw = 1; Tcl_CreateCommand(interp, "stdscr", WinProc, cd2, 0); return TCL_OK; } else { Tcl_AddErrorInfo(interp, "curses "); Tcl_AddErrorInfo(interp, argv[1]); Tcl_AddErrorInfo(interp, ": must start by calling initscr"); return TCL_ERROR; } } if (argc == 2 && *argv[1] == 'e' && !strcmp(argv[1], "endwin")) { /*XX curses endwin */ if (endwin() == OK) { return TCL_OK; } return Error(interp, "<none>", argv[1]); } if (argc > 2 && *argv[1] == 'm' && !strcmp(argv[1], "mode")) { /*XX curses mode <[no]cbreak> <[no]nl> <[no]echo> <[no]raw> */ --argc; ++argv; while (argc > 1) { if (*argv[1] == 'c' && !strcmp(argv[1], "cbreak")) { if (cd->cbreak || cbreak() == OK) { cd->cbreak = 1; } else { return Error(interp, "<none>", argv[1]); } } else if (*argv[1] == 'n' && !strcmp(argv[1], "nocbreak")) { if (!cd->cbreak || nocbreak() == OK) { cd->cbreak = 0; } else { return Error(interp, "<none>", argv[1]); } } else if (*argv[1] == 'e' && !strcmp(argv[1], "echo")) { if (cd->echo || echo() == OK) { cd->echo = 1; } else { return Error(interp, "<none>", argv[1]); } } else if (*argv[1] == 'n' && !strcmp(argv[1], "noecho")) { if (!cd->echo || noecho() == OK) { cd->echo = 0; } else { return Error(interp, "<none>", argv[1]); } } else if (*argv[1] == 'r' && !strcmp(argv[1], "raw")) { if (cd->raw || raw() == OK) { cd->raw = 1; } else { return Error(interp, "<none>", argv[1]); } } else if (*argv[1] == 'n' && !strcmp(argv[1], "noraw")) { if (!cd->raw || noraw() == OK) { cd->raw = 0; } else { return Error(interp, "<none>", argv[1]); } } else if (*argv[1] == 'n' && !strcmp(argv[1], "nl")) { if (cd->nl || nl() == OK) { cd->nl = 1; } else { return Error(interp, "<none>", argv[1]); } } else if (*argv[1] == 'n' && !strcmp(argv[1], "nonl")) { if (!cd->nl || nonl() == OK) { cd->nl = 0; } else { return Error(interp, "<none>", argv[1]); } } else { fprintf(stderr, "%s %d\n", argv[1], argc); Tcl_AddErrorInfo(interp, "curses "); Tcl_AddErrorInfo(interp, argv[1]); Tcl_AddErrorInfo(interp, ": Huh ?"); return TCL_ERROR; } ++argv; --argc; } if (argc < 2) { return TCL_OK; } } if (argc == 2 && *argv[1] == 'i' && !strcmp(argv[1], "info")) { /*XX curses info */ char buf[30]; sprintf(buf, "%s%s %s%s %s%s %s%s", cd->cbreak ? "" : "no", "cbreak", cd->raw ? "" : "no", "raw", cd->nl ? "" : "no", "nl", cd->echo ? "" : "no", "echo"); Tcl_SetResult(interp, buf, TCL_STATIC); return TCL_OK; } if (argc == 7 && *argv[1] == 'n' && !strcmp(argv[1], "newwin")) { /*XX curses newwin <win> <nlin> <ncol> <begin_y> <begin_x> */ WINDOW *w; w = newwin(atoi(argv[3]), atoi(argv[4]), atoi(argv[5]), atoi(argv[6])); if (!w) { return Error(interp, argv[1], argv[2]); } cd2 = (t_cldat2 *)ckalloc(sizeof *cd2); memset(cd2, 0, sizeof *cd2); cd2->cd = cd; cd2->border = NULL; cd2->win = w; cd2->wbox = 0; /* by default, no border */ Tcl_CreateCommand(interp, argv[2], WinProc, cd2, 0); return TCL_OK; } Tcl_AddErrorInfo(interp, "curses "); Tcl_AddErrorInfo(interp, argv[1]); Tcl_AddErrorInfo(interp, ": Huh ?"); return TCL_ERROR; } static int WinProc(t_cldat2 *cd2, Tcl_Interp *interp, int argc, char **argv) { int i; Tcl_HashEntry *he; char *win = *argv; if (cd2->cd->debug) { fprintf(stderr, "CURSES: WinProc %d ", argc); for (i = 0 ; i < argc; ++i) { fprintf(stderr, "{%s} ", argv[i]); } fprintf(stderr, "\n"); } if (argc < 2) { Tcl_AddErrorInfo(interp, "curses "); Tcl_AddErrorInfo(interp, win); Tcl_AddErrorInfo(interp, ": no args"); return TCL_ERROR; } while (argc > 1 && *argv[1] == '-') { if (argc >= 4 && !strcmp(argv[1], "-m")) { /*XX <win> [-m <lin> <pos>] */ if (OK != wmove(cd2->win, atoi(argv[2]), atoi(argv[3]))) { Error(interp, win, argv[1]); } argv += 3; argc -= 3; } else if (argc >= 3 && !strcmp(argv[1], "-a")) { /*XX <win> [-a <{|so|ul|rev|blink|dim|bold}*> ] */ char *s, *t; i = 0; for (t = argv[2]; t && *t; t = s) { for (s = t; *s && !isspace(*s); ++s); if (!*s) { s = 0; } else { *s++ = '\0'; } if (!strcmp(t, "so")) {i |= A_STANDOUT;} else if (!strcmp(t, "ul")) {i |= A_UNDERLINE;} else if (!strcmp(t, "rev")) {i |= A_REVERSE;} else if (!strcmp(t, "blink")) {i |= A_BLINK;} else if (!strcmp(t, "dim")) {i |= A_DIM;} else if (!strcmp(t, "bold")) {i |= A_BOLD;} else { Tcl_AddErrorInfo(interp, "curses "); Tcl_AddErrorInfo(interp, win); Tcl_AddErrorInfo(interp, " "); Tcl_AddErrorInfo(interp, argv[1]); Tcl_AddErrorInfo(interp, " "); Tcl_AddErrorInfo(interp, t); Tcl_AddErrorInfo(interp, ": Huh ?"); return TCL_ERROR; } } wattrset(cd2->win, i); argv += 2; argc -= 2; } else { Tcl_AddErrorInfo(interp, "curses "); Tcl_AddErrorInfo(interp, win); Tcl_AddErrorInfo(interp, " "); Tcl_AddErrorInfo(interp, argv[1]); Tcl_AddErrorInfo(interp, ": Huh ?"); return TCL_ERROR; } } if (argc == 1) { return TCL_OK; } if (argc == 3 && *argv[1] == 'b' && !strcmp(argv[1], "box")) { /*XX box [on | off]*/ int bx, by, ex, ey; if (!strcmp(argv[2], "on")) { if (cd2->wbox) { /* already on! */ return Error(interp, win, argv[1]); } /* not on, so make make border on */ cd2->wbox = 1; cd2->border = cd2->win; getbegyx(cd2->border, by, bx); getmaxyx(cd2->border, ey, ex); cd2->win = newwin(ey - 2, ex - 2, by + 1, bx + 1); if (!cd2->win) { cd2->wbox = 0; cd2->win = cd2->border; cd2->border = NULL; return Error(interp, win, argv[1]); } overwrite(cd2->border, cd2->win); box(cd2->border, 0, 0); } if (!strcmp(argv[2], "off")) { if (!cd2->wbox) { return Error(interp, win, argv[1]); } /* box can be turned off */ cd2->wbox = 0; werase(cd2->border); overwrite(cd2->win, cd2->border); delwin(cd2->win); cd2->win = cd2->border; cd2->border = NULL; } return TCL_OK; } if (argc == 3 && *argv[1] == 'a' && !strcmp(argv[1], "addstr")) { /*XX <win> addstr <string> */ if (OK == waddstr(cd2->win, argv[2])) { return TCL_OK; } return Error(interp, win, argv[1]); } if (argc == 2 && *argv[1] == 'c' && !strcmp(argv[1], "clrtoeol")) { /*XX <win> clrtoeol */ wclrtoeol(cd2->win); return TCL_OK; } if (argc == 2 && *argv[1] == 'c' && !strcmp(argv[1], "clrtobot")) { /*XX <win> clrtobot */ wclrtobot(cd2->win); return TCL_OK; } if (argc == 2 && *argv[1] == 'r' && !strcmp(argv[1], "refresh")) { /*XX <win> refresh */ if (cd2->wbox) { wrefresh(cd2->border); wrefresh(cd2->win); return TCL_OK; } } if (argc == 2 && *argv[1] == 'e' && !strcmp(argv[1], "erase")) { /*XX <win> erase */ werase(cd2->win); return TCL_OK; } if (argc == 2 && *argv[1] == 'c' && !strcmp(argv[1], "clear")) { /*XX <win> clear */ wclear(cd2->win); return TCL_OK; } if (argc == 2 && *argv[1] == 'g' && !strcmp(argv[1], "getch")) { /*XX <win> getch */ char buf[2]; buf[1] = 0; buf[0] = wgetch(cd2->win); Tcl_SetResult(interp, buf, TCL_STATIC); return TCL_OK; } if (argc == 3 && *argv[1] == 'g' && !strcmp(argv[1], "getstr")) { /*XX <win> getstr <maxstrsize>*/ char *buf; buf = malloc(1 + atoi(argv[2])); if (!buf) { return Error(interp, win, argv[1]); } memset(buf, 0, 1 + atoi(argv[2])); if (OK != wgetstr(cd2->win, buf)) { free(buf); return Error(interp, win, argv[1]); } Tcl_SetResult(interp, buf, TCL_STATIC); free(buf); return TCL_OK; } Tcl_AddErrorInfo(interp, "curses "); Tcl_AddErrorInfo(interp, win); Tcl_AddErrorInfo(interp, ": >>"); Tcl_AddErrorInfo(interp, argv[1]); Tcl_AddErrorInfo(interp, "<< Huh ?"); return TCL_ERROR; }