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
curses refresh : actually do refresh to physical screen
curses timeout <milliseconds> : Time to wait for a key (-ve makes
getch non-blocking)
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.2") == 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.
2004-08-02 VI And curses digital clock for another