2004-02-11 [VI]

I looked around for a curses package, so I could make my sysadmin
scripts be more friendly.  Here's a minimalist approach.  A package
which allows access to the bare bones.  I think this should be enough
to build any text UI, with everything else in Tcl.

----

 /* curses.c
  * A "minimalist" tcl package for interfacing to curses.  Goes into
  * curses mode on load and automatically comes out at exit
  *
  * Usage:
  *
  * curses init (no need to call, automatically done at load)
  * curses end  (no need to call, automatically done at exit)
  * curses attr <on/off> <standout/underline/reverse/blink/dim/bold/alt>
  * curses move <row> <column> : move to screen position, 0 0 is top left
  * curses puts  : print a string
  * curses getch : get a character
  * curses info  <rows/cols> : return the number of rows/cols in screen
  * curses erase : clear the screen
  *
  * Build: 
  * gcc -I/usr/local/tcl/8.4.5/include -fPIC -c curses.c -o curses.o
  *
  * (something like this, which is on solaris7):
  * ld -r curses.o -o curses.so -Bsymbolic /usr/lib/libcurses.a
  * (on linux)
  * gcc -shared curses.o -o curses.so /usr/lib/libcurses.a
  */
 
 #include "tcl.h"
 #include <curses.h>
 
 /*
  * Forward declarations for procedures defined later in this file:
  */
 
 static int cursesCmd _ANSI_ARGS_ ((ClientData dummy,
 				Tcl_Interp *interp, int objc, 
 				Tcl_Obj *CONST objv[]));
 
 static int curses_start (void);
 static void curses_exit  (ClientData dummy); /* exit handler */
 
 /*
  *----------------------------------------------------------------------
  *
  * Curses_Init --
  *
  *	This procedure is the main initialisation point of the Curses
  *	extension.
  *
  * Results:
  *	Returns a standard Tcl completion code, and leaves an error
  *	message in the interp's result if an error occurs.  We're OK
  *      to init in a safe interpreter.  No file access done.
  *
  * Side effects:
  *	Adds a command to the Tcl interpreter.  Adds an exit handler
  *      and changes the screen into raw mode
  *
  *----------------------------------------------------------------------
  */
 
 
 int
 Curses_Init (interp)
     Tcl_Interp *interp;		/* Interpreter for application */
 {
     if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
 	return TCL_ERROR;
     }
     if (Tcl_PkgRequire(interp, "Tcl", "8.4", 0) == NULL) {
 	return TCL_ERROR;
     }
     if (Tcl_PkgProvide(interp, "curses", "0.7.1") == TCL_ERROR) {
         return TCL_ERROR;
     }
     
     Tcl_CreateObjCommand(interp, "curses", cursesCmd, 
 			 (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
 
     curses_start();
     Tcl_CreateExitHandler(curses_exit,(ClientData) NULL);
     return TCL_OK;
 }
 
 /*
  * curses_exit -- exit handler for curses
  * Results: -- none
  * Side effects: gets out of curses by calling endwin
  */
 
 static void
 curses_exit (ClientData dummy)
 {
     endwin();
 }
 
 
 /* An error reporting routine for varargs results
  * Results : -- always TCL_ERROR, so we can just return
  * the value of this call
  * Side effects: Sets the result in the interpreter.
  */
 
 #define MAX_ERROR_SIZE   1024
 
 static int 
 setTclError TCL_VARARGS_DEF (
     Tcl_Interp *,
     i)
 {
     va_list argList;
     char buf[MAX_ERROR_SIZE];
     char *format;
     
     Tcl_Interp *interp = TCL_VARARGS_START(Tcl_Interp *, i, argList);
     format = va_arg(argList, char *);
     vsnprintf(buf, MAX_ERROR_SIZE, format, argList);
     buf[MAX_ERROR_SIZE-1] = '\0';
     Tcl_SetResult(interp, buf, TCL_VOLATILE);
     return TCL_ERROR;
 } 
 
 /*
  * curses_start -- init handler for curses. called on loading
  * Results: -- always TCL_OK
  * Side effects: gets into curses mode.
  */
 
 static int
 curses_start(void)
 {
     initscr();		/* will exit if there is an error */
     if (has_colors())	/* use colors if we have them */
 	start_color();
     cbreak();
     noecho();
     nonl();
     intrflush(stdscr,FALSE);
     keypad(stdscr,TRUE);
     return TCL_OK;
 }
 
 /*
  * --------------------------------------------------------------- 
  * cursesCmd --
  *
  * Implmements the "curses" command.  Doesn't do colors yet
  * 
  * Results:
  *      A standard Tcl result. 
  *
  * Side effects:
  *      See the curses man page.  All side effects are inside the
  *      the library or on the screen!
  * 
  * Usage is listed at the top of this file
  */
     
 static int 
 cursesCmd (dummy, interp, objc, objv)
     ClientData dummy;
     Tcl_Interp *interp;
     int		objc;
     Tcl_Obj	*CONST objv[];
 {
     int index;
 
     static CONST char *optionStrings[] = {
 	"init", "end", "attr", "move", 
 	"puts", "getch", "info", "erase", 
 	"refresh", "timeout",
 	NULL
     };
 
     enum options {
 	CURSES_INIT, CURSES_END, CURSES_ATTR, CURSES_MOVE, 
 	CURSES_PUTS, CURSES_GETCH, CURSES_INFO, CURSES_ERASE,
 	CURSES_REFRESH, CURSES_TIMEOUT
     };
 
     static CONST char *attrStrings[] = {
 	"standout", "underline", "reverse", 
 	"blink", "dim", "bold", 
 	"alt", NULL
     };
 
     enum attrs {
 	CURSES_A_STANDOUT, CURSES_A_UNDERLINE, CURSES_A_REVERSE,
 	CURSES_A_BLINK,    CURSES_A_DIM,       CURSES_A_BOLD,
 	CURSES_A_ALT
     };
 
     static CONST char *infoStrings[] = {
 	"cols", "lines", NULL
     };
 
     enum infos {
 	CURSES_COLS,      CURSES_LINES
     };
 
     static CONST int attrVals[] = {
 	A_STANDOUT,   A_UNDERLINE,   A_REVERSE,
 	A_BLINK,      A_DIM,         A_BOLD, 
 	A_ALTCHARSET
     };
 
     if (objc < 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
 	return TCL_ERROR;
     }
     
     if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
 	    &index) != TCL_OK) 
 	return TCL_ERROR;
 
     switch ((enum options) index) {
     case CURSES_INIT: {
 	return curses_start();
     }
     case CURSES_END: {
 	endwin();
 	return TCL_OK;
     }
     case CURSES_ATTR: { 
 	int on, index, attr;
 
 	if (objc != 4) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "boolean attribute");
 	    return TCL_ERROR;
 	}
 	if (Tcl_GetBooleanFromObj(interp, objv[2], &on) != TCL_OK) 
 	    return TCL_ERROR;
 	if (Tcl_GetIndexFromObj(interp, objv[3], attrStrings, 
 				"attribute", 0, &index) != TCL_OK) 
 	    return TCL_ERROR;	/* perhaps allow an integer here? */
 	attr = attrVals[index];
 	if (on) {
 	    attron(attr);
 	}  else {
 	    attroff(attr);
 	}
 	return TCL_OK;
     }
     case CURSES_MOVE: {
 	int row, col;
 	if (objc != 4) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "row col");
 	    return TCL_ERROR;
 	}
 	if (Tcl_GetIntFromObj(interp, objv[2], &row) != TCL_OK)
 	    return TCL_ERROR;
 	if (Tcl_GetIntFromObj(interp, objv[3], &col) != TCL_OK)
 	    return TCL_ERROR;
 	move(row, col);
 	return TCL_OK;
     }
     case CURSES_PUTS: {
 	if (objc != 3) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "string");
 	    return TCL_ERROR;
 	}
 	addstr(Tcl_GetString(objv[2]));
 	return TCL_OK;
     }
     case CURSES_GETCH: {
 	Tcl_SetObjResult(interp,Tcl_NewIntObj(getch()));
 	return TCL_OK;
     }
     case CURSES_INFO: {
 	int index;
 
 	if (objc != 3) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "characteristic");
 	    return TCL_ERROR;
 	}
 	if (Tcl_GetIndexFromObj(interp, objv[2], infoStrings,
 				"characteristic", 0, &index) != TCL_OK)
 	    return TCL_ERROR;
 	switch ((enum infos) index) {
 	case CURSES_COLS: {
 	    Tcl_SetObjResult(interp,Tcl_NewIntObj(COLS));
 	    return TCL_OK;
 	}
 	case CURSES_LINES: {
 	    Tcl_SetObjResult(interp,Tcl_NewIntObj(LINES));
 	    return TCL_OK;
 	}
 	default: {
 	    return setTclError(interp, "Couldn't understand info "
 			       "characteristic %d", index);
 	}
 	}
 	return TCL_OK;
     }
     case CURSES_ERASE: {
 	if (objc != 2) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "");
 	    return TCL_ERROR;
 	}
 	erase();
 	return TCL_OK;
     }
     case CURSES_REFRESH: {
 	if (objc != 2) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "");
 	    return TCL_ERROR;
 	}
 	refresh();
 	return TCL_OK;
     }
     case CURSES_TIMEOUT: {
 	int ms;
 
 	if (objc != 3) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "milliseconds");
 	    return TCL_ERROR;
 	}
 	if (Tcl_GetIntFromObj(interp, objv[2], &ms) != TCL_OK)
 	    return TCL_ERROR;
 	timeout(ms);
 	return TCL_OK;
     }
     default: {
 	return setTclError(interp, "Couldn't understand enum %d as "
 			   "action type", index);
     }
     }
 }
 

----
The obvious missing things are color (and because this is curses and NOT
ncurses, we don't have mouse and resize handling).

2004-02-12 [VI] add refresh and timeout (non-blocking) options to command.
include linux build instructions
----
[DKF]: Arguably, just doing the [package require] should cause the initialisation of the curses subsystem.
----
2004-02-13 [VI] It does.   The pkgIndex.tcl is just one line:

 package ifneeded curses 0.7.2 [list load [file join $dir curses.so]]

And it also gets back to normal mode automatically on exit (an exit handler is installed
during init).

See a [curses screen saver] for an example.
----