[GRASS-SVN] r35199 - in grass/trunk/lib: . form
svn_grass at osgeo.org
svn_grass at osgeo.org
Sun Jan 4 10:47:39 EST 2009
Author: martinl
Date: 2009-01-04 10:47:39 -0500 (Sun, 04 Jan 2009)
New Revision: 35199
Added:
grass/trunk/lib/form/
grass/trunk/lib/form/Makefile
grass/trunk/lib/form/form.c
grass/trunk/lib/form/form.tcl
grass/trunk/lib/form/generate.c
grass/trunk/lib/form/html_library.tcl
grass/trunk/lib/form/html_library_grass.tcl
grass/trunk/lib/form/license.terms
grass/trunk/lib/form/open.c
grass/trunk/lib/form/todo
Removed:
grass/trunk/lib/form/Makefile
grass/trunk/lib/form/form.c
grass/trunk/lib/form/form.tcl
grass/trunk/lib/form/generate.c
grass/trunk/lib/form/html_library.tcl
grass/trunk/lib/form/html_library_grass.tcl
grass/trunk/lib/form/license.terms
grass/trunk/lib/form/open.c
grass/trunk/lib/form/todo
Modified:
grass/trunk/lib/Makefile
Log:
revert r35194: nviz requires lib/form
Modified: grass/trunk/lib/Makefile
===================================================================
--- grass/trunk/lib/Makefile 2009-01-04 15:45:02 UTC (rev 35198)
+++ grass/trunk/lib/Makefile 2009-01-04 15:47:39 UTC (rev 35199)
@@ -20,6 +20,7 @@
db \
external \
fonts \
+ form \
imagery \
cluster \
proj \
Copied: grass/trunk/lib/form (from rev 35193, grass/trunk/lib/form)
Property changes on: grass/trunk/lib/form
___________________________________________________________________
Name: svn:ignore
+ *OBJ*
Deleted: grass/trunk/lib/form/Makefile
===================================================================
--- grass/trunk/lib/form/Makefile 2009-01-04 14:37:12 UTC (rev 35193)
+++ grass/trunk/lib/form/Makefile 2009-01-04 15:47:39 UTC (rev 35199)
@@ -1,39 +0,0 @@
-MODULE_TOPDIR = ../..
-
-include $(MODULE_TOPDIR)/include/Make/Vars.make
-
-MOD_OBJS = generate.o open.o
-
-LIB_NAME = $(FORM_LIBNAME)
-
-include $(MODULE_TOPDIR)/include/Make/Lib.make
-
-EXTRA_LIBS=$(GISLIB) $(DBMILIB)
-EXTRA_CFLAGS = $(XCFLAGS) $(TCLINCDIR) $(TKINCDIR)
-
-FORMDIR=$(ARCH_DISTDIR)/etc/form
-FORM=$(FORMDIR)/form.tcl
-FORMPROG=$(FORMDIR)/form
-HTMLLIB=$(FORMDIR)/html_library.tcl
-
-ifneq ($(TCLTKLIBS),)
- GTCLTKFORM = $(HTMLLIB) $(FORM) $(FORMPROG)
-endif
-
-default: lib $(GTCLTKFORM)
-
-$(FORMDIR):
- if [ ! -d $@ ]; then $(MKDIR) $@; fi
-
-$(HTMLLIB): html_library_grass.tcl
- $(MAKE) $(FORMDIR)
- $(INSTALL_DATA) $< $@
-
-$(FORM): form.tcl
- $(MAKE) $(FORMDIR)
- $(INSTALL_DATA) $< $@
-
-$(FORMPROG): $(OBJDIR)/form.o
- $(MAKE) $(FORMDIR)
- $(CC) $(LDFLAGS) -o $@ $(OBJDIR)/form.o $(DBMILIB) $(GISLIB) $(DATETIMELIB) \
- $(TCLTKLIBPATH) $(TCLTKLIBS) $(MATHLIB) $(XDRLIB)
Copied: grass/trunk/lib/form/Makefile (from rev 35193, grass/trunk/lib/form/Makefile)
===================================================================
--- grass/trunk/lib/form/Makefile (rev 0)
+++ grass/trunk/lib/form/Makefile 2009-01-04 15:47:39 UTC (rev 35199)
@@ -0,0 +1,39 @@
+MODULE_TOPDIR = ../..
+
+include $(MODULE_TOPDIR)/include/Make/Vars.make
+
+MOD_OBJS = generate.o open.o
+
+LIB_NAME = $(FORM_LIBNAME)
+
+include $(MODULE_TOPDIR)/include/Make/Lib.make
+
+EXTRA_LIBS=$(GISLIB) $(DBMILIB)
+EXTRA_CFLAGS = $(XCFLAGS) $(TCLINCDIR) $(TKINCDIR)
+
+FORMDIR=$(ARCH_DISTDIR)/etc/form
+FORM=$(FORMDIR)/form.tcl
+FORMPROG=$(FORMDIR)/form
+HTMLLIB=$(FORMDIR)/html_library.tcl
+
+ifneq ($(TCLTKLIBS),)
+ GTCLTKFORM = $(HTMLLIB) $(FORM) $(FORMPROG)
+endif
+
+default: lib $(GTCLTKFORM)
+
+$(FORMDIR):
+ if [ ! -d $@ ]; then $(MKDIR) $@; fi
+
+$(HTMLLIB): html_library_grass.tcl
+ $(MAKE) $(FORMDIR)
+ $(INSTALL_DATA) $< $@
+
+$(FORM): form.tcl
+ $(MAKE) $(FORMDIR)
+ $(INSTALL_DATA) $< $@
+
+$(FORMPROG): $(OBJDIR)/form.o
+ $(MAKE) $(FORMDIR)
+ $(CC) $(LDFLAGS) -o $@ $(OBJDIR)/form.o $(DBMILIB) $(GISLIB) $(DATETIMELIB) \
+ $(TCLTKLIBPATH) $(TCLTKLIBS) $(MATHLIB) $(XDRLIB)
Deleted: grass/trunk/lib/form/form.c
===================================================================
--- grass/trunk/lib/form/form.c 2009-01-04 14:37:12 UTC (rev 35193)
+++ grass/trunk/lib/form/form.c 2009-01-04 15:47:39 UTC (rev 35199)
@@ -1,308 +0,0 @@
-#include <stdlib.h>
-#include <string.h>
-#include <stdio.h>
-#include <unistd.h>
-#include <fcntl.h>
-#include <sys/time.h>
-#include <sys/types.h>
-#include <tcl.h>
-#include <tk.h>
-#include <locale.h>
-#include <grass/gis.h>
-#include <grass/dbmi.h>
-#include <grass/form.h>
-
-/* Structure to store column names and values */
-typedef struct
-{
- char *name;
- int ctype;
- char *value;
-} COLUMN;
-
-static char *Drvname, *Dbname, *Tblname, *Key;
-
-static COLUMN *Columns = NULL;
-static int allocatedRows = 0; /* allocated space */
-static int nRows = 0;
-
-/* Start new sql update */
-int reset_values(ClientData cdata, Tcl_Interp * interp, int argc,
- char *argv[])
-{
- nRows = 0;
- Drvname = NULL;
- Dbname = NULL;
- Tblname = NULL;
- Key = NULL;
-
- return TCL_OK;
-}
-
-int set_value(ClientData cdata, Tcl_Interp * interp, int argc, char *argv[])
-{
- G_debug(2, "set_value(): %s %s", argv[1], argv[2]);
-
- if (strcmp(argv[1], F_DRIVER_FNAME) == 0) {
- Drvname = G_store(argv[2]);
- }
- else if (strcmp(argv[1], F_DATABASE_FNAME) == 0) {
- Dbname = G_store(argv[2]);
- }
- else if (strcmp(argv[1], F_TABLE_FNAME) == 0) {
- Tblname = G_store(argv[2]);
- }
- else if (strcmp(argv[1], F_KEY_FNAME) == 0) {
- Key = G_store(argv[2]);
- }
- else {
- if (nRows == allocatedRows) {
- allocatedRows += 100;
- Columns =
- (COLUMN *) G_realloc(Columns,
- (allocatedRows) * sizeof(COLUMN));
- }
- Columns[nRows].name = G_store(argv[1]);
- Columns[nRows].value = G_store(argv[2]);
- nRows++;
- }
-
- return TCL_OK;
-}
-
-/* Update table, use the data previously stored by set_value() */
-int submit(ClientData cdata, Tcl_Interp * interp, int argc, char *argv[])
-{
- int i, first, ncols, found, col, sqltype, keyval = 0, ret;
- char buf[2001];
- dbString sql, table_name, strval;
- dbDriver *driver;
- dbHandle handle;
- dbTable *table;
- dbColumn *column;
-
- G_debug(2, "submit()");
-
- db_init_string(&sql);
- db_init_string(&table_name);
- db_init_string(&strval);
-
- /* Check if all internal values are set */
- if (Drvname == NULL || Dbname == NULL || Tblname == NULL || Key == NULL) {
- G_warning("db connection was not set by form\n");
- sprintf(buf, "set submit_msg \"db connection was not set by form.\"");
- Tcl_Eval(interp, buf);
- Tcl_Eval(interp, "set submit_result 0");
- return TCL_OK;
- }
-
- /* Get column types */
- G_debug(2, "Open driver");
- driver = db_start_driver(Drvname);
- if (driver == NULL) {
- G_warning("Cannot open driver\n");
- sprintf(buf, "set submit_msg \"Cannot open driver '%s'\"", Drvname);
- Tcl_Eval(interp, buf);
- Tcl_Eval(interp, "set submit_result 0");
- return TCL_OK;
- }
- G_debug(2, "Driver opened");
-
- db_init_handle(&handle);
- db_set_handle(&handle, Dbname, NULL);
- G_debug(2, "Open database");
- if (db_open_database(driver, &handle) != DB_OK) {
- G_warning("Cannot open database\n");
- db_shutdown_driver(driver);
- sprintf(buf,
- "set submit_msg \"Cannot open database '%s' by driver '%s'\"",
- Dbname, Drvname);
- Tcl_Eval(interp, buf);
- Tcl_Eval(interp, "set submit_result 0");
- return TCL_OK;
- }
- G_debug(2, "Database opened");
-
- db_set_string(&table_name, Tblname);
- if (db_describe_table(driver, &table_name, &table) != DB_OK) {
- G_warning("Cannot describe table\n");
- db_shutdown_driver(driver);
- db_close_database(driver);
- sprintf(buf, "set submit_msg \"Cannot describe table '%s'\"",
- Tblname);
- Tcl_Eval(interp, buf);
- Tcl_Eval(interp, "set submit_result 0");
- return TCL_OK;
- }
- ncols = db_get_table_number_of_columns(table);
-
- /* For each column get ctype */
- for (i = 0; i < nRows; i++) {
- found = 0;
- for (col = 0; col < ncols; col++) {
- /* get keyval */
- if (G_strcasecmp(Columns[i].name, Key) == 0) {
- keyval = atoi(Columns[i].value);
- }
- column = db_get_table_column(table, col);
- if (G_strcasecmp(db_get_column_name(column), Columns[i].name) ==
- 0) {
- sqltype = db_get_column_sqltype(column);
- Columns[i].ctype = db_sqltype_to_Ctype(sqltype);
- found = 1;
- break;
- }
- }
- if (!found && (G_strcasecmp(Columns[i].name, F_ENCODING) != 0)) {
- G_warning("Cannot find column type");
- db_close_database(driver);
- db_shutdown_driver(driver);
- sprintf(buf, "set submit_msg \"Cannot find column type\"");
- Tcl_Eval(interp, buf);
- Tcl_Eval(interp, "set submit_result 0");
- return TCL_OK;
- }
- }
-
- /* Construct update statement */
- sprintf(buf, "update %s set ", Tblname);
- db_set_string(&sql, buf);
-
- first = 1;
- for (i = 0; i < nRows; i++) {
- G_debug(3, "Index = %d of %d Name = %s, Key = %s", i, nRows,
- Columns[i].name, Key);
- if (G_strcasecmp(Columns[i].name, Key) == 0)
- continue;
-
- if (G_strcasecmp(Columns[i].name, F_ENCODING) == 0) {
-
- G_debug(3, "GRASS_DB_ENCODING env-var is '%s', col val is '%s'",
- G__getenv("GRASS_DB_ENCODING"), Columns[i].value);
-
- if ((strlen(Columns[i].value) == 0) ||
- G_strcasecmp(Columns[i].value,
- G__getenv("GRASS_DB_ENCODING")) == 0)
- continue;
- else {
- G_setenv("GRASS_DB_ENCODING", Columns[i].value);
- G_debug(3, "Set env var GRASS_DB_ENCODING to '%s'",
- Columns[i].value);
- if (Tcl_SetSystemEncoding(interp, Columns[i].value) ==
- TCL_ERROR) {
- G_warning
- ("Could not set Tcl system encoding to '%s' (%s)",
- Columns[i].value, interp->result);
- }
- }
- continue;
- }
-
- if (!first) {
- db_append_string(&sql, ", ");
- }
- if (strlen(Columns[i].value) == 0) {
- sprintf(buf, "%s = null", Columns[i].name);
- }
- else {
- if (Columns[i].ctype == DB_C_TYPE_INT ||
- Columns[i].ctype == DB_C_TYPE_DOUBLE) {
- sprintf(buf, "%s = %s", Columns[i].name, Columns[i].value);
- }
- else {
- memset(buf, '\0', strlen(buf));
- ret = Tcl_UtfToExternal(interp,
- Tcl_GetEncoding(interp,
- G__getenv
- ("GRASS_DB_ENCODING")),
- Columns[i].value,
- strlen(Columns[i].value), 0, NULL,
- buf, 2000, NULL, NULL, NULL);
-
- if (ret != TCL_OK) {
- G_warning("Could not convert UTF to external.");
- db_set_string(&strval, Columns[i].value);
- }
- else {
- db_set_string(&strval, buf);
- }
-
- db_double_quote_string(&strval);
- sprintf(buf, "%s = '%s'", Columns[i].name,
- db_get_string(&strval));
- }
- }
- db_append_string(&sql, buf);
- first = 0;
- }
-
- sprintf(buf, " where %s = %d", Key, keyval);
- db_append_string(&sql, buf);
-
- G_debug(2, "SQL: %s", db_get_string(&sql));
-
- /* Update table */
- ret = db_execute_immediate(driver, &sql);
-
- db_close_database(driver);
- db_shutdown_driver(driver);
-
- if (ret != DB_OK) {
- G_warning("Cannot update table");
- Tcl_VarEval(interp, "set submit_msg \"Cannot update table:\n",
- db_get_error_msg(), "\"", NULL);
- Tcl_Eval(interp, "set submit_result 0");
- }
- else {
- Tcl_Eval(interp, "set submit_msg \"Record successfully updated\"");
- Tcl_Eval(interp, "set submit_result 1");
- }
-
- return TCL_OK;
-}
-
-/*
- * Form
- */
-int Tcl_AppInit(Tcl_Interp * interp)
-{
- if (Tcl_Init(interp) == TCL_ERROR)
- return TCL_ERROR;
-
- if (Tk_Init(interp) == TCL_ERROR)
- return TCL_ERROR;
-
- Tcl_StaticPackage(interp, "Tk", Tk_Init, Tk_SafeInit);
-
- /*
- * Call Tcl_CreateCommand for application-specific commands, if
- * they weren't already created by the init procedures called above.
- */
-
- Tcl_CreateCommand(interp, "submit", (Tcl_CmdProc *) submit,
- (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "set_value",
- (Tcl_CmdProc *) set_value,
- (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
- Tcl_CreateCommand(interp, "reset_values",
- (Tcl_CmdProc *) reset_values,
- (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
- /*
- * Specify a user-specific startup file to invoke if the application
- * is run interactively. Typically the startup file is "~/.apprc"
- * where "app" is the name of the application. If this line is deleted
- * then no user-specific startup file will be run under any conditions.
- */
-
- Tcl_SetVar(interp, "tcl_rcFileName", "~/.grassformrc", TCL_GLOBAL_ONLY);
- return TCL_OK;
-}
-
-int main(int argc, char *argv[])
-{
- G_gisinit("form");
- G_debug(2, "Form: main()");
-
- Tk_Main(argc, argv, Tcl_AppInit);
- return 0;
-}
Copied: grass/trunk/lib/form/form.c (from rev 35193, grass/trunk/lib/form/form.c)
===================================================================
--- grass/trunk/lib/form/form.c (rev 0)
+++ grass/trunk/lib/form/form.c 2009-01-04 15:47:39 UTC (rev 35199)
@@ -0,0 +1,308 @@
+#include <stdlib.h>
+#include <string.h>
+#include <stdio.h>
+#include <unistd.h>
+#include <fcntl.h>
+#include <sys/time.h>
+#include <sys/types.h>
+#include <tcl.h>
+#include <tk.h>
+#include <locale.h>
+#include <grass/gis.h>
+#include <grass/dbmi.h>
+#include <grass/form.h>
+
+/* Structure to store column names and values */
+typedef struct
+{
+ char *name;
+ int ctype;
+ char *value;
+} COLUMN;
+
+static char *Drvname, *Dbname, *Tblname, *Key;
+
+static COLUMN *Columns = NULL;
+static int allocatedRows = 0; /* allocated space */
+static int nRows = 0;
+
+/* Start new sql update */
+int reset_values(ClientData cdata, Tcl_Interp * interp, int argc,
+ char *argv[])
+{
+ nRows = 0;
+ Drvname = NULL;
+ Dbname = NULL;
+ Tblname = NULL;
+ Key = NULL;
+
+ return TCL_OK;
+}
+
+int set_value(ClientData cdata, Tcl_Interp * interp, int argc, char *argv[])
+{
+ G_debug(2, "set_value(): %s %s", argv[1], argv[2]);
+
+ if (strcmp(argv[1], F_DRIVER_FNAME) == 0) {
+ Drvname = G_store(argv[2]);
+ }
+ else if (strcmp(argv[1], F_DATABASE_FNAME) == 0) {
+ Dbname = G_store(argv[2]);
+ }
+ else if (strcmp(argv[1], F_TABLE_FNAME) == 0) {
+ Tblname = G_store(argv[2]);
+ }
+ else if (strcmp(argv[1], F_KEY_FNAME) == 0) {
+ Key = G_store(argv[2]);
+ }
+ else {
+ if (nRows == allocatedRows) {
+ allocatedRows += 100;
+ Columns =
+ (COLUMN *) G_realloc(Columns,
+ (allocatedRows) * sizeof(COLUMN));
+ }
+ Columns[nRows].name = G_store(argv[1]);
+ Columns[nRows].value = G_store(argv[2]);
+ nRows++;
+ }
+
+ return TCL_OK;
+}
+
+/* Update table, use the data previously stored by set_value() */
+int submit(ClientData cdata, Tcl_Interp * interp, int argc, char *argv[])
+{
+ int i, first, ncols, found, col, sqltype, keyval = 0, ret;
+ char buf[2001];
+ dbString sql, table_name, strval;
+ dbDriver *driver;
+ dbHandle handle;
+ dbTable *table;
+ dbColumn *column;
+
+ G_debug(2, "submit()");
+
+ db_init_string(&sql);
+ db_init_string(&table_name);
+ db_init_string(&strval);
+
+ /* Check if all internal values are set */
+ if (Drvname == NULL || Dbname == NULL || Tblname == NULL || Key == NULL) {
+ G_warning("db connection was not set by form\n");
+ sprintf(buf, "set submit_msg \"db connection was not set by form.\"");
+ Tcl_Eval(interp, buf);
+ Tcl_Eval(interp, "set submit_result 0");
+ return TCL_OK;
+ }
+
+ /* Get column types */
+ G_debug(2, "Open driver");
+ driver = db_start_driver(Drvname);
+ if (driver == NULL) {
+ G_warning("Cannot open driver\n");
+ sprintf(buf, "set submit_msg \"Cannot open driver '%s'\"", Drvname);
+ Tcl_Eval(interp, buf);
+ Tcl_Eval(interp, "set submit_result 0");
+ return TCL_OK;
+ }
+ G_debug(2, "Driver opened");
+
+ db_init_handle(&handle);
+ db_set_handle(&handle, Dbname, NULL);
+ G_debug(2, "Open database");
+ if (db_open_database(driver, &handle) != DB_OK) {
+ G_warning("Cannot open database\n");
+ db_shutdown_driver(driver);
+ sprintf(buf,
+ "set submit_msg \"Cannot open database '%s' by driver '%s'\"",
+ Dbname, Drvname);
+ Tcl_Eval(interp, buf);
+ Tcl_Eval(interp, "set submit_result 0");
+ return TCL_OK;
+ }
+ G_debug(2, "Database opened");
+
+ db_set_string(&table_name, Tblname);
+ if (db_describe_table(driver, &table_name, &table) != DB_OK) {
+ G_warning("Cannot describe table\n");
+ db_shutdown_driver(driver);
+ db_close_database(driver);
+ sprintf(buf, "set submit_msg \"Cannot describe table '%s'\"",
+ Tblname);
+ Tcl_Eval(interp, buf);
+ Tcl_Eval(interp, "set submit_result 0");
+ return TCL_OK;
+ }
+ ncols = db_get_table_number_of_columns(table);
+
+ /* For each column get ctype */
+ for (i = 0; i < nRows; i++) {
+ found = 0;
+ for (col = 0; col < ncols; col++) {
+ /* get keyval */
+ if (G_strcasecmp(Columns[i].name, Key) == 0) {
+ keyval = atoi(Columns[i].value);
+ }
+ column = db_get_table_column(table, col);
+ if (G_strcasecmp(db_get_column_name(column), Columns[i].name) ==
+ 0) {
+ sqltype = db_get_column_sqltype(column);
+ Columns[i].ctype = db_sqltype_to_Ctype(sqltype);
+ found = 1;
+ break;
+ }
+ }
+ if (!found && (G_strcasecmp(Columns[i].name, F_ENCODING) != 0)) {
+ G_warning("Cannot find column type");
+ db_close_database(driver);
+ db_shutdown_driver(driver);
+ sprintf(buf, "set submit_msg \"Cannot find column type\"");
+ Tcl_Eval(interp, buf);
+ Tcl_Eval(interp, "set submit_result 0");
+ return TCL_OK;
+ }
+ }
+
+ /* Construct update statement */
+ sprintf(buf, "update %s set ", Tblname);
+ db_set_string(&sql, buf);
+
+ first = 1;
+ for (i = 0; i < nRows; i++) {
+ G_debug(3, "Index = %d of %d Name = %s, Key = %s", i, nRows,
+ Columns[i].name, Key);
+ if (G_strcasecmp(Columns[i].name, Key) == 0)
+ continue;
+
+ if (G_strcasecmp(Columns[i].name, F_ENCODING) == 0) {
+
+ G_debug(3, "GRASS_DB_ENCODING env-var is '%s', col val is '%s'",
+ G__getenv("GRASS_DB_ENCODING"), Columns[i].value);
+
+ if ((strlen(Columns[i].value) == 0) ||
+ G_strcasecmp(Columns[i].value,
+ G__getenv("GRASS_DB_ENCODING")) == 0)
+ continue;
+ else {
+ G_setenv("GRASS_DB_ENCODING", Columns[i].value);
+ G_debug(3, "Set env var GRASS_DB_ENCODING to '%s'",
+ Columns[i].value);
+ if (Tcl_SetSystemEncoding(interp, Columns[i].value) ==
+ TCL_ERROR) {
+ G_warning
+ ("Could not set Tcl system encoding to '%s' (%s)",
+ Columns[i].value, interp->result);
+ }
+ }
+ continue;
+ }
+
+ if (!first) {
+ db_append_string(&sql, ", ");
+ }
+ if (strlen(Columns[i].value) == 0) {
+ sprintf(buf, "%s = null", Columns[i].name);
+ }
+ else {
+ if (Columns[i].ctype == DB_C_TYPE_INT ||
+ Columns[i].ctype == DB_C_TYPE_DOUBLE) {
+ sprintf(buf, "%s = %s", Columns[i].name, Columns[i].value);
+ }
+ else {
+ memset(buf, '\0', strlen(buf));
+ ret = Tcl_UtfToExternal(interp,
+ Tcl_GetEncoding(interp,
+ G__getenv
+ ("GRASS_DB_ENCODING")),
+ Columns[i].value,
+ strlen(Columns[i].value), 0, NULL,
+ buf, 2000, NULL, NULL, NULL);
+
+ if (ret != TCL_OK) {
+ G_warning("Could not convert UTF to external.");
+ db_set_string(&strval, Columns[i].value);
+ }
+ else {
+ db_set_string(&strval, buf);
+ }
+
+ db_double_quote_string(&strval);
+ sprintf(buf, "%s = '%s'", Columns[i].name,
+ db_get_string(&strval));
+ }
+ }
+ db_append_string(&sql, buf);
+ first = 0;
+ }
+
+ sprintf(buf, " where %s = %d", Key, keyval);
+ db_append_string(&sql, buf);
+
+ G_debug(2, "SQL: %s", db_get_string(&sql));
+
+ /* Update table */
+ ret = db_execute_immediate(driver, &sql);
+
+ db_close_database(driver);
+ db_shutdown_driver(driver);
+
+ if (ret != DB_OK) {
+ G_warning("Cannot update table");
+ Tcl_VarEval(interp, "set submit_msg \"Cannot update table:\n",
+ db_get_error_msg(), "\"", NULL);
+ Tcl_Eval(interp, "set submit_result 0");
+ }
+ else {
+ Tcl_Eval(interp, "set submit_msg \"Record successfully updated\"");
+ Tcl_Eval(interp, "set submit_result 1");
+ }
+
+ return TCL_OK;
+}
+
+/*
+ * Form
+ */
+int Tcl_AppInit(Tcl_Interp * interp)
+{
+ if (Tcl_Init(interp) == TCL_ERROR)
+ return TCL_ERROR;
+
+ if (Tk_Init(interp) == TCL_ERROR)
+ return TCL_ERROR;
+
+ Tcl_StaticPackage(interp, "Tk", Tk_Init, Tk_SafeInit);
+
+ /*
+ * Call Tcl_CreateCommand for application-specific commands, if
+ * they weren't already created by the init procedures called above.
+ */
+
+ Tcl_CreateCommand(interp, "submit", (Tcl_CmdProc *) submit,
+ (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "set_value",
+ (Tcl_CmdProc *) set_value,
+ (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "reset_values",
+ (Tcl_CmdProc *) reset_values,
+ (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
+ /*
+ * Specify a user-specific startup file to invoke if the application
+ * is run interactively. Typically the startup file is "~/.apprc"
+ * where "app" is the name of the application. If this line is deleted
+ * then no user-specific startup file will be run under any conditions.
+ */
+
+ Tcl_SetVar(interp, "tcl_rcFileName", "~/.grassformrc", TCL_GLOBAL_ONLY);
+ return TCL_OK;
+}
+
+int main(int argc, char *argv[])
+{
+ G_gisinit("form");
+ G_debug(2, "Form: main()");
+
+ Tk_Main(argc, argv, Tcl_AppInit);
+ return 0;
+}
Deleted: grass/trunk/lib/form/form.tcl
===================================================================
--- grass/trunk/lib/form/form.tcl 2009-01-04 14:37:12 UTC (rev 35193)
+++ grass/trunk/lib/form/form.tcl 2009-01-04 15:47:39 UTC (rev 35199)
@@ -1,158 +0,0 @@
-lappend auto_path $env(GISBASE)/bwidget
-package require -exact BWidget 1.2.1
-#package require http
-
-set formpath $env(GISBASE)/etc/form
-source $formpath/html_library.tcl
-
-proc create_submit_msg { formid } {
- global submit_result submit_msg formf
-
- destroy $formf($formid).sbw
- destroy $formf($formid).sbt
-
- if { $submit_result == 1 } { set color "green" } else { set color "red" }
- set sbw [ScrolledWindow $formf($formid).sbw -relief sunken -borderwidth 2]
- set sbt [text $formf($formid).sbt -height 3 -width 20 -foreground $color ]
- pack $sbw $sbt -fill x
- $sbw setwidget $sbt
- $sbt insert end $submit_msg
- $sbt configure -state disabled
-}
-
-proc add_form { formid title } {
- global nb formf html
-
- set form($formid) [$nb insert end $formid -text $title]
- $nb raise $formid
- set formf($formid) [ frame $form($formid).frm ]
- set formsw($formid) [ScrolledWindow $formf($formid).sw -relief sunken -borderwidth 2]
- set formtxt($formid) [ text $formf($formid).txt -height 5 -width 20 ]
- pack $formf($formid) $formsw($formid) $formtxt($formid) -fill both -expand yes
- $formsw($formid) setwidget $formtxt($formid)
- HMinit_win $formtxt($formid)
- HMparse_html $html "HMrender $formtxt($formid)"
- $formtxt($formid) configure -state disabled
-}
-
-proc clear_nb { } {
- global submit_msg
-
- set submit_msg ""
-
- foreach frm [ .nb pages ] {
- .nb delete $frm
- }
-}
-
-proc HMsubmit_form {win param query} {
- global submit_result submit_msg
-
- regexp -- {\.nb\.f(.+)\.frm\.txt} $win r formid
- #puts "win = $win formid = $formid"
-
- reset_values
- foreach {col val} $query {
- #puts "$col : $val"
- set_value $col $val
- }
-
- submit $formid
- #puts "result = $submit_result msg = $submit_msg"
- create_submit_msg $formid
-}
-
-proc make_form {} {
- global nb
-
- set nb [NoteBook .nb]
- $nb configure -width 300 -height 500
- pack .nb -fill both -expand yes
-}
-
-proc close_form {} {
- global form_open
- wm withdraw .
- set form_open false
-}
-
-proc process_command {} {
- global env
- global child_recv child_send
- global form_open encoding_val frmid
- global html
-
- if {[eof $child_recv]} {
- exit 0
- }
-
- set cmd [read $child_recv 1]
-
- switch $cmd {
- O {
- if {! $form_open} {
- wm state . normal
- set form_open true
- }
- # Read title
- set length [gets $child_recv]
- set child_title [read $child_recv $length]
-
- # Read html
- set length [gets $child_recv]
- set child_html [read $child_recv $length]
-
- set child_html [encoding convertfrom $encoding_val $child_html]
-
- # Insert new page
- set html $child_html
- add_form $frmid $child_title
-
- puts -nonewline $child_send O
- flush $child_send
- incr frmid
- }
- C { # clear old forms
- clear_nb
- puts -nonewline $child_send O
- flush $child_send
- }
- D { # done!
- clear_nb
- puts -nonewline $child_send O
- flush $child_send
-
- destroy .
- exit 0
- }
- }
-}
-
-make_form
-
-wm protocol . WM_DELETE_WINDOW close_form
-
-bind . <Destroy> { if { "%W" == "."} { close_form } }
-
-set submit_result ""
-set submit_msg ""
-set html ""
-
-set frmid 0
-set form_open true
-
-set child_recv stdin
-set child_send stdout
-
-set encoding_val [exec g.gisenv GRASS_DB_ENCODING]
-if {$encoding_val == ""} {
- set encoding_val [encoding system]
-}
-
-if {[catch {encoding system $encoding_val}]} {
- puts stderr "Could not set Tcl system encoding to $encoding_val"
-}
-
-fconfigure $child_recv -buffering none -encoding binary -translation binary
-
-fileevent $child_recv readable process_command
Copied: grass/trunk/lib/form/form.tcl (from rev 35193, grass/trunk/lib/form/form.tcl)
===================================================================
--- grass/trunk/lib/form/form.tcl (rev 0)
+++ grass/trunk/lib/form/form.tcl 2009-01-04 15:47:39 UTC (rev 35199)
@@ -0,0 +1,158 @@
+lappend auto_path $env(GISBASE)/bwidget
+package require -exact BWidget 1.2.1
+#package require http
+
+set formpath $env(GISBASE)/etc/form
+source $formpath/html_library.tcl
+
+proc create_submit_msg { formid } {
+ global submit_result submit_msg formf
+
+ destroy $formf($formid).sbw
+ destroy $formf($formid).sbt
+
+ if { $submit_result == 1 } { set color "green" } else { set color "red" }
+ set sbw [ScrolledWindow $formf($formid).sbw -relief sunken -borderwidth 2]
+ set sbt [text $formf($formid).sbt -height 3 -width 20 -foreground $color ]
+ pack $sbw $sbt -fill x
+ $sbw setwidget $sbt
+ $sbt insert end $submit_msg
+ $sbt configure -state disabled
+}
+
+proc add_form { formid title } {
+ global nb formf html
+
+ set form($formid) [$nb insert end $formid -text $title]
+ $nb raise $formid
+ set formf($formid) [ frame $form($formid).frm ]
+ set formsw($formid) [ScrolledWindow $formf($formid).sw -relief sunken -borderwidth 2]
+ set formtxt($formid) [ text $formf($formid).txt -height 5 -width 20 ]
+ pack $formf($formid) $formsw($formid) $formtxt($formid) -fill both -expand yes
+ $formsw($formid) setwidget $formtxt($formid)
+ HMinit_win $formtxt($formid)
+ HMparse_html $html "HMrender $formtxt($formid)"
+ $formtxt($formid) configure -state disabled
+}
+
+proc clear_nb { } {
+ global submit_msg
+
+ set submit_msg ""
+
+ foreach frm [ .nb pages ] {
+ .nb delete $frm
+ }
+}
+
+proc HMsubmit_form {win param query} {
+ global submit_result submit_msg
+
+ regexp -- {\.nb\.f(.+)\.frm\.txt} $win r formid
+ #puts "win = $win formid = $formid"
+
+ reset_values
+ foreach {col val} $query {
+ #puts "$col : $val"
+ set_value $col $val
+ }
+
+ submit $formid
+ #puts "result = $submit_result msg = $submit_msg"
+ create_submit_msg $formid
+}
+
+proc make_form {} {
+ global nb
+
+ set nb [NoteBook .nb]
+ $nb configure -width 300 -height 500
+ pack .nb -fill both -expand yes
+}
+
+proc close_form {} {
+ global form_open
+ wm withdraw .
+ set form_open false
+}
+
+proc process_command {} {
+ global env
+ global child_recv child_send
+ global form_open encoding_val frmid
+ global html
+
+ if {[eof $child_recv]} {
+ exit 0
+ }
+
+ set cmd [read $child_recv 1]
+
+ switch $cmd {
+ O {
+ if {! $form_open} {
+ wm state . normal
+ set form_open true
+ }
+ # Read title
+ set length [gets $child_recv]
+ set child_title [read $child_recv $length]
+
+ # Read html
+ set length [gets $child_recv]
+ set child_html [read $child_recv $length]
+
+ set child_html [encoding convertfrom $encoding_val $child_html]
+
+ # Insert new page
+ set html $child_html
+ add_form $frmid $child_title
+
+ puts -nonewline $child_send O
+ flush $child_send
+ incr frmid
+ }
+ C { # clear old forms
+ clear_nb
+ puts -nonewline $child_send O
+ flush $child_send
+ }
+ D { # done!
+ clear_nb
+ puts -nonewline $child_send O
+ flush $child_send
+
+ destroy .
+ exit 0
+ }
+ }
+}
+
+make_form
+
+wm protocol . WM_DELETE_WINDOW close_form
+
+bind . <Destroy> { if { "%W" == "."} { close_form } }
+
+set submit_result ""
+set submit_msg ""
+set html ""
+
+set frmid 0
+set form_open true
+
+set child_recv stdin
+set child_send stdout
+
+set encoding_val [exec g.gisenv GRASS_DB_ENCODING]
+if {$encoding_val == ""} {
+ set encoding_val [encoding system]
+}
+
+if {[catch {encoding system $encoding_val}]} {
+ puts stderr "Could not set Tcl system encoding to $encoding_val"
+}
+
+fconfigure $child_recv -buffering none -encoding binary -translation binary
+
+fileevent $child_recv readable process_command
Deleted: grass/trunk/lib/form/generate.c
===================================================================
--- grass/trunk/lib/form/generate.c 2009-01-04 14:37:12 UTC (rev 35193)
+++ grass/trunk/lib/form/generate.c 2009-01-04 15:47:39 UTC (rev 35199)
@@ -1,253 +0,0 @@
-#include <stdlib.h>
-#include <string.h>
-#include <grass/gis.h>
-#include <grass/dbmi.h>
-#include <grass/form.h>
-
-/* Generate form in HTML/TXT format.
- * Pointer to resulting string is stored to 'form'. This string must be freed by application.
- *
- * returns: -1 error
- * 0 success
- */
-int
-F_generate(char *drvname, char *dbname, char *tblname, char *key, int keyval,
- char *frmname, char *frmmapset,
- int edit_mode, int format, char **form)
-{
- int col, ncols, ctype, sqltype, more;
- char buf[5000], buf1[100];
- const char *colname;
- dbString sql, html, str;
- dbDriver *driver;
- dbHandle handle;
- dbCursor cursor;
- dbTable *table;
- dbColumn *column;
- dbValue *value;
-
- int i = 0;
-
- /* see /usr/lib/tcl8.4/encoding/ */
- static char *encoding_list[] = {
- "utf-8",
- "ascii",
- "iso8859-1",
- "iso8859-2",
- "iso8859-15",
- "iso2022-jp",
- "koi8-r",
- "euc-jp",
- NULL
- };
- const char *enc_env;
-
- G__read_env();
- enc_env = G__getenv("GRASS_DB_ENCODING");
-
- /* TODO: support 'format' (txt, html), currently html only */
-
- G_debug(2,
- "F_generate(): drvname = '%s', dbname = '%s'\n tblname = '%s', key = '%s', keyval = %d\n"
- " form = '%s', form_mapset = '%s'\n edit_mode = %d",
- drvname, dbname, tblname, key, keyval, frmname, frmmapset,
- edit_mode);
-
- db_init_string(&sql);
- db_init_string(&html); /* here is the result stored */
- db_init_string(&str);
-
- G_debug(2, "Open driver");
- driver = db_start_driver(drvname);
- if (driver == NULL) {
- G_warning("Cannot open driver\n");
- sprintf(buf, "Cannot open driver '%s'<BR>", drvname);
- *form = G_store(buf);
- return -1;
- }
- G_debug(2, "Driver opened");
-
- db_init_handle(&handle);
- db_set_handle(&handle, dbname, NULL);
- G_debug(2, "Open database");
- if (db_open_database(driver, &handle) != DB_OK) {
- G_warning("Cannot open database\n");
- db_shutdown_driver(driver);
- sprintf(buf, "Cannot open database '%s' by driver '%s'<BR>", dbname,
- drvname);
- *form = G_store(buf);
- return -1;
- }
- G_debug(2, "Database opened");
-
- /* TODO: test if table exist first, but this should be tested by application befor
- * F_generate() is called, because it may be correct (connection defined in DB
- * but table does not exist) */
-
- sprintf(buf, "select * from %s where %s = %d", tblname, key, keyval);
- G_debug(2, "%s", buf);
- db_set_string(&sql, buf);
- if (db_open_select_cursor(driver, &sql, &cursor, DB_SEQUENTIAL) != DB_OK) {
- G_warning("Cannot open select cursor\n");
- db_close_database(driver);
- db_shutdown_driver(driver);
- sprintf(buf,
- "Cannot open select cursor:<BR>'%s'<BR>on database '%s' by driver '%s'<BR>",
- db_get_string(&sql), dbname, drvname);
- *form = G_store(buf);
- return -1;
- }
- G_debug(2, "Select Cursor opened");
-
- table = db_get_cursor_table(&cursor);
-
- if (db_fetch(&cursor, DB_NEXT, &more) != DB_OK) {
- G_warning("Cannot fetch next record\n");
- db_close_cursor(&cursor);
- db_close_database(driver);
- db_shutdown_driver(driver);
- *form = G_store("Cannot fetch next record");
- return -1;
- }
-
- if (!more) {
- G_warning("No database record");
- if (format == F_HTML) {
- *form = G_store("No record selected.<BR>");
- }
- else {
- *form = G_store("No record selected.");
- }
- }
- else {
- ncols = db_get_table_number_of_columns(table);
-
- /* Start form */
- if (format == F_HTML) {
- if (edit_mode == F_EDIT) {
- db_append_string(&html, "<FORM>");
-
- sprintf(buf, "<INPUT type=hidden name=%s value=\"%s\">",
- F_DRIVER_FNAME, drvname);
- db_append_string(&html, buf);
- /* Note: because html_library.tcl failes to parse
- * <INPUT name=abc value='dbname=xxx'> and returnes
- * name="xxx" value="dbname=xxx" order of value and name parameters is changed */
- sprintf(buf, "<INPUT type=hidden value=\"%s\" name=%s>",
- dbname, F_DATABASE_FNAME);
- db_append_string(&html, buf);
- sprintf(buf, "<INPUT type=hidden name=%s value=\"%s\">",
- F_TABLE_FNAME, tblname);
- db_append_string(&html, buf);
- sprintf(buf, "<INPUT type=hidden name=%s value=\"%s\">",
- F_KEY_FNAME, key);
- db_append_string(&html, buf);
-
- }
-
- for (col = 0; col < ncols; col++) {
- column = db_get_table_column(table, col);
- sqltype = db_get_column_sqltype(column);
- ctype = db_sqltype_to_Ctype(sqltype);
- value = db_get_column_value(column);
- db_convert_value_to_string(value, sqltype, &str);
- colname = db_get_column_name(column);
-
- G_debug(2, "%s: %s", colname, db_get_string(&str));
-
- if (edit_mode == F_VIEW) {
- sprintf(buf, "<B>%s : </B> %s <BR>", colname,
- db_get_string(&str));
- db_append_string(&html, buf);
- }
- else {
- sprintf(buf, "<B>%s : </B>", colname);
- db_append_string(&html, buf);
-
- if (G_strcasecmp(colname, key) == 0) {
- sprintf(buf,
- "%s<BR> <INPUT type=hidden name=%s value=\"%s\">",
- db_get_string(&str), colname,
- db_get_string(&str));
- }
- else {
- switch (ctype) {
- case DB_C_TYPE_INT:
- sprintf(buf1, "20");
- break;
- case DB_C_TYPE_DOUBLE:
- sprintf(buf1, "30");
- break;
- case DB_C_TYPE_STRING:
- sprintf(buf1, "%d", db_get_column_length(column));
- break;
- case DB_C_TYPE_DATETIME:
- sprintf(buf1, "20");
- break;
- }
- sprintf(buf,
- "<INPUT type=text size=%s name=%s value=\"%s\"><BR>",
- buf1, colname, db_get_string(&str));
- }
- db_append_string(&html, buf);
- }
- }
-
- if (edit_mode == F_EDIT) {
- sprintf(buf,
- "<HR> Assume data encoding as:<BR><BR><SELECT NAME=%s SIZE=4><HR><BR>",
- F_ENCODING);
- db_append_string(&html, buf);
-
- i = 0;
- while (encoding_list[i] != NULL) {
-
- if (G_strcasecmp(encoding_list[i], enc_env) == 0)
- sprintf(buf, "<OPTION VALUE=\"%s\" SELECTED>%s",
- encoding_list[i], encoding_list[i]);
- else
- sprintf(buf, "<OPTION VALUE=\"%s\">%s",
- encoding_list[i], encoding_list[i]);
- ++i;
- db_append_string(&html, buf);
- }
-
- sprintf(buf, "</SELECT>");
- db_append_string(&html, buf);
- }
-
- /* Close form */
- if (edit_mode == F_EDIT) {
- db_append_string(&html, "</FORM>");
- }
- }
- else { /* F_TXT */
- for (col = 0; col < ncols; col++) {
- column = db_get_table_column(table, col);
- sqltype = db_get_column_sqltype(column);
- ctype = db_sqltype_to_Ctype(sqltype);
- value = db_get_column_value(column);
- db_convert_value_to_string(value, sqltype, &str);
- colname = db_get_column_name(column);
-
- G_debug(2, "%s: %s", colname, db_get_string(&str));
-
- sprintf(buf, "%s : %s\n", colname, db_get_string(&str));
- db_append_string(&html, buf);
- }
- }
- }
- G_debug(2, "FORM STRING:\n%s\n", db_get_string(&html));
-
- db_close_cursor(&cursor);
- db_close_database(driver);
- db_shutdown_driver(driver);
-
- *form = G_store(db_get_string(&html));
-
- db_free_string(&sql);
- db_free_string(&html);
- db_free_string(&str);
-
- return 0;
-}
Copied: grass/trunk/lib/form/generate.c (from rev 35193, grass/trunk/lib/form/generate.c)
===================================================================
--- grass/trunk/lib/form/generate.c (rev 0)
+++ grass/trunk/lib/form/generate.c 2009-01-04 15:47:39 UTC (rev 35199)
@@ -0,0 +1,253 @@
+#include <stdlib.h>
+#include <string.h>
+#include <grass/gis.h>
+#include <grass/dbmi.h>
+#include <grass/form.h>
+
+/* Generate form in HTML/TXT format.
+ * Pointer to resulting string is stored to 'form'. This string must be freed by application.
+ *
+ * returns: -1 error
+ * 0 success
+ */
+int
+F_generate(char *drvname, char *dbname, char *tblname, char *key, int keyval,
+ char *frmname, char *frmmapset,
+ int edit_mode, int format, char **form)
+{
+ int col, ncols, ctype, sqltype, more;
+ char buf[5000], buf1[100];
+ const char *colname;
+ dbString sql, html, str;
+ dbDriver *driver;
+ dbHandle handle;
+ dbCursor cursor;
+ dbTable *table;
+ dbColumn *column;
+ dbValue *value;
+
+ int i = 0;
+
+ /* see /usr/lib/tcl8.4/encoding/ */
+ static char *encoding_list[] = {
+ "utf-8",
+ "ascii",
+ "iso8859-1",
+ "iso8859-2",
+ "iso8859-15",
+ "iso2022-jp",
+ "koi8-r",
+ "euc-jp",
+ NULL
+ };
+ const char *enc_env;
+
+ G__read_env();
+ enc_env = G__getenv("GRASS_DB_ENCODING");
+
+ /* TODO: support 'format' (txt, html), currently html only */
+
+ G_debug(2,
+ "F_generate(): drvname = '%s', dbname = '%s'\n tblname = '%s', key = '%s', keyval = %d\n"
+ " form = '%s', form_mapset = '%s'\n edit_mode = %d",
+ drvname, dbname, tblname, key, keyval, frmname, frmmapset,
+ edit_mode);
+
+ db_init_string(&sql);
+ db_init_string(&html); /* here is the result stored */
+ db_init_string(&str);
+
+ G_debug(2, "Open driver");
+ driver = db_start_driver(drvname);
+ if (driver == NULL) {
+ G_warning("Cannot open driver\n");
+ sprintf(buf, "Cannot open driver '%s'<BR>", drvname);
+ *form = G_store(buf);
+ return -1;
+ }
+ G_debug(2, "Driver opened");
+
+ db_init_handle(&handle);
+ db_set_handle(&handle, dbname, NULL);
+ G_debug(2, "Open database");
+ if (db_open_database(driver, &handle) != DB_OK) {
+ G_warning("Cannot open database\n");
+ db_shutdown_driver(driver);
+ sprintf(buf, "Cannot open database '%s' by driver '%s'<BR>", dbname,
+ drvname);
+ *form = G_store(buf);
+ return -1;
+ }
+ G_debug(2, "Database opened");
+
+ /* TODO: test if table exist first, but this should be tested by application befor
+ * F_generate() is called, because it may be correct (connection defined in DB
+ * but table does not exist) */
+
+ sprintf(buf, "select * from %s where %s = %d", tblname, key, keyval);
+ G_debug(2, "%s", buf);
+ db_set_string(&sql, buf);
+ if (db_open_select_cursor(driver, &sql, &cursor, DB_SEQUENTIAL) != DB_OK) {
+ G_warning("Cannot open select cursor\n");
+ db_close_database(driver);
+ db_shutdown_driver(driver);
+ sprintf(buf,
+ "Cannot open select cursor:<BR>'%s'<BR>on database '%s' by driver '%s'<BR>",
+ db_get_string(&sql), dbname, drvname);
+ *form = G_store(buf);
+ return -1;
+ }
+ G_debug(2, "Select Cursor opened");
+
+ table = db_get_cursor_table(&cursor);
+
+ if (db_fetch(&cursor, DB_NEXT, &more) != DB_OK) {
+ G_warning("Cannot fetch next record\n");
+ db_close_cursor(&cursor);
+ db_close_database(driver);
+ db_shutdown_driver(driver);
+ *form = G_store("Cannot fetch next record");
+ return -1;
+ }
+
+ if (!more) {
+ G_warning("No database record");
+ if (format == F_HTML) {
+ *form = G_store("No record selected.<BR>");
+ }
+ else {
+ *form = G_store("No record selected.");
+ }
+ }
+ else {
+ ncols = db_get_table_number_of_columns(table);
+
+ /* Start form */
+ if (format == F_HTML) {
+ if (edit_mode == F_EDIT) {
+ db_append_string(&html, "<FORM>");
+
+ sprintf(buf, "<INPUT type=hidden name=%s value=\"%s\">",
+ F_DRIVER_FNAME, drvname);
+ db_append_string(&html, buf);
+ /* Note: because html_library.tcl failes to parse
+ * <INPUT name=abc value='dbname=xxx'> and returnes
+ * name="xxx" value="dbname=xxx" order of value and name parameters is changed */
+ sprintf(buf, "<INPUT type=hidden value=\"%s\" name=%s>",
+ dbname, F_DATABASE_FNAME);
+ db_append_string(&html, buf);
+ sprintf(buf, "<INPUT type=hidden name=%s value=\"%s\">",
+ F_TABLE_FNAME, tblname);
+ db_append_string(&html, buf);
+ sprintf(buf, "<INPUT type=hidden name=%s value=\"%s\">",
+ F_KEY_FNAME, key);
+ db_append_string(&html, buf);
+
+ }
+
+ for (col = 0; col < ncols; col++) {
+ column = db_get_table_column(table, col);
+ sqltype = db_get_column_sqltype(column);
+ ctype = db_sqltype_to_Ctype(sqltype);
+ value = db_get_column_value(column);
+ db_convert_value_to_string(value, sqltype, &str);
+ colname = db_get_column_name(column);
+
+ G_debug(2, "%s: %s", colname, db_get_string(&str));
+
+ if (edit_mode == F_VIEW) {
+ sprintf(buf, "<B>%s : </B> %s <BR>", colname,
+ db_get_string(&str));
+ db_append_string(&html, buf);
+ }
+ else {
+ sprintf(buf, "<B>%s : </B>", colname);
+ db_append_string(&html, buf);
+
+ if (G_strcasecmp(colname, key) == 0) {
+ sprintf(buf,
+ "%s<BR> <INPUT type=hidden name=%s value=\"%s\">",
+ db_get_string(&str), colname,
+ db_get_string(&str));
+ }
+ else {
+ switch (ctype) {
+ case DB_C_TYPE_INT:
+ sprintf(buf1, "20");
+ break;
+ case DB_C_TYPE_DOUBLE:
+ sprintf(buf1, "30");
+ break;
+ case DB_C_TYPE_STRING:
+ sprintf(buf1, "%d", db_get_column_length(column));
+ break;
+ case DB_C_TYPE_DATETIME:
+ sprintf(buf1, "20");
+ break;
+ }
+ sprintf(buf,
+ "<INPUT type=text size=%s name=%s value=\"%s\"><BR>",
+ buf1, colname, db_get_string(&str));
+ }
+ db_append_string(&html, buf);
+ }
+ }
+
+ if (edit_mode == F_EDIT) {
+ sprintf(buf,
+ "<HR> Assume data encoding as:<BR><BR><SELECT NAME=%s SIZE=4><HR><BR>",
+ F_ENCODING);
+ db_append_string(&html, buf);
+
+ i = 0;
+ while (encoding_list[i] != NULL) {
+
+ if (G_strcasecmp(encoding_list[i], enc_env) == 0)
+ sprintf(buf, "<OPTION VALUE=\"%s\" SELECTED>%s",
+ encoding_list[i], encoding_list[i]);
+ else
+ sprintf(buf, "<OPTION VALUE=\"%s\">%s",
+ encoding_list[i], encoding_list[i]);
+ ++i;
+ db_append_string(&html, buf);
+ }
+
+ sprintf(buf, "</SELECT>");
+ db_append_string(&html, buf);
+ }
+
+ /* Close form */
+ if (edit_mode == F_EDIT) {
+ db_append_string(&html, "</FORM>");
+ }
+ }
+ else { /* F_TXT */
+ for (col = 0; col < ncols; col++) {
+ column = db_get_table_column(table, col);
+ sqltype = db_get_column_sqltype(column);
+ ctype = db_sqltype_to_Ctype(sqltype);
+ value = db_get_column_value(column);
+ db_convert_value_to_string(value, sqltype, &str);
+ colname = db_get_column_name(column);
+
+ G_debug(2, "%s: %s", colname, db_get_string(&str));
+
+ sprintf(buf, "%s : %s\n", colname, db_get_string(&str));
+ db_append_string(&html, buf);
+ }
+ }
+ }
+ G_debug(2, "FORM STRING:\n%s\n", db_get_string(&html));
+
+ db_close_cursor(&cursor);
+ db_close_database(driver);
+ db_shutdown_driver(driver);
+
+ *form = G_store(db_get_string(&html));
+
+ db_free_string(&sql);
+ db_free_string(&html);
+ db_free_string(&str);
+
+ return 0;
+}
Deleted: grass/trunk/lib/form/html_library.tcl
===================================================================
--- grass/trunk/lib/form/html_library.tcl 2009-01-04 14:37:12 UTC (rev 35193)
+++ grass/trunk/lib/form/html_library.tcl 2009-01-04 15:47:39 UTC (rev 35199)
@@ -1,1417 +0,0 @@
-# Simple HTML display library by Stephen Uhler (stephen.uhler at sun.com)
-# Copyright (c) 1995 by Sun Microsystems
-# Version 0.3 Fri Sep 1 10:47:17 PDT 1995
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# To use this package, create a text widget (say, .text)
-# and set a variable full of html, (say $html), and issue:
-# HMinit_win .text
-# HMparse_html $html "HMrender .text"
-# You also need to supply the routine:
-# proc HMlink_callback {win href} { ...}
-# win: The name of the text widget
-# href The name of the link
-# which will be called anytime the user "clicks" on a link.
-# The supplied version just prints the link to stdout.
-# In addition, if you wish to use embedded images, you will need to write
-# proc HMset_image {handle src}
-# handle an arbitrary handle (not really)
-# src The name of the image
-# Which calls
-# HMgot_image $handle $image
-# with the TK image.
-#
-# To return a "used" text widget to its initialized state, call:
-# HMreset_win .text
-# See "sample.tcl" for sample usage
-##################################################################
-############################################
-# mapping of html tags to text tag properties
-# properties beginning with "T" map directly to text tags
-
-# These are Defined in HTML 2.0
-
-array set HMtag_map {
- b {weight bold}
- blockquote {style i indent 1 Trindent rindent}
- bq {style i indent 1 Trindent rindent}
- cite {style i}
- code {family courier}
- dfn {style i}
- dir {indent 1}
- dl {indent 1}
- em {style i}
- h1 {size 24 weight bold}
- h2 {size 22}
- h3 {size 20}
- h4 {size 18}
- h5 {size 16}
- h6 {style i}
- i {style i}
- kbd {family courier weight bold}
- menu {indent 1}
- ol {indent 1}
- pre {fill 0 family courier Tnowrap nowrap}
- samp {family courier}
- strong {weight bold}
- tt {family courier}
- u {Tunderline underline}
- ul {indent 1}
- var {style i}
-}
-
-# These are in common(?) use, but not defined in html2.0
-
-array set HMtag_map {
- center {Tcenter center}
- strike {Tstrike strike}
- u {Tunderline underline}
-}
-
-# initial values
-
-set HMtag_map(hmstart) {
- family times weight medium style r size 14
- Tcenter "" Tlink "" Tnowrap "" Tunderline "" list list
- fill 1 indent "" counter 0 adjust 0
-}
-
-# html tags that insert white space
-
-array set HMinsert_map {
- blockquote "\n\n" /blockquote "\n"
- br "\n"
- dd "\n" /dd "\n"
- dl "\n" /dl "\n"
- dt "\n"
- form "\n" /form "\n"
- h1 "\n\n" /h1 "\n"
- h2 "\n\n" /h2 "\n"
- h3 "\n\n" /h3 "\n"
- h4 "\n" /h4 "\n"
- h5 "\n" /h5 "\n"
- h6 "\n" /h6 "\n"
- li "\n"
- /dir "\n"
- /ul "\n"
- /ol "\n"
- /menu "\n"
- p "\n\n"
- pre "\n" /pre "\n"
-}
-
-# tags that are list elements, that support "compact" rendering
-
-array set HMlist_elements {
- ol 1 ul 1 menu 1 dl 1 dir 1
-}
-############################################
-# initialize the window and stack state
-
-proc HMinit_win {win} {
- upvar #0 HM$win var
-
- HMinit_state $win
- $win tag configure underline -underline 1
- $win tag configure center -justify center
- $win tag configure nowrap -wrap none
- $win tag configure rindent -rmargin $var(S_tab)c
- $win tag configure strike -overstrike 1
- $win tag configure mark -foreground red ;# list markers
- $win tag configure list -spacing1 3p -spacing3 3p ;# regular lists
- $win tag configure compact -spacing1 0p ;# compact lists
- $win tag configure link -borderwidth 2 -foreground blue ;# hypertext links
- HMset_indent $win $var(S_tab)
- $win configure -wrap word
-
- # configure the text insertion point
- $win mark set $var(S_insert) 1.0
-
- # for horizontal rules
- $win tag configure thin -font [HMx_font times 2 medium r]
- $win tag configure hr -relief sunken -borderwidth 2 -wrap none \
- -tabs [winfo width $win]
- bind $win <Configure> {
- %W tag configure hr -tabs %w
- %W tag configure last -spacing3 %h
- }
-
- # generic link enter callback
-
- $win tag bind link <1> "HMlink_hit $win %x %y"
-}
-
-# set the indent spacing (in cm) for lists
-# TK uses a "weird" tabbing model that causes \t to insert a single
-# space if the current line position is past the tab setting
-
-proc HMset_indent {win cm} {
- set tabs [expr $cm / 2.0]
- $win configure -tabs ${tabs}c
- foreach i {1 2 3 4 5 6 7 8 9} {
- set tab [expr $i * $cm]
- $win tag configure indent$i -lmargin1 ${tab}c -lmargin2 ${tab}c \
- -tabs "[expr $tab + $tabs]c [expr $tab + 2*$tabs]c"
- }
-}
-
-# reset the state of window - get ready for the next page
-# remove all but the font tags, and remove all form state
-
-proc HMreset_win {win} {
- upvar #0 HM$win var
- regsub -all { +[^L ][^ ]*} " [$win tag names] " {} tags
- catch "$win tag delete $tags"
- eval $win mark unset [$win mark names]
- $win delete 0.0 end
- $win tag configure hr -tabs [winfo width $win]
-
- # configure the text insertion point
- $win mark set $var(S_insert) 1.0
-
- # remove form state. If any check/radio buttons still exists,
- # their variables will be magically re-created, and never get
- # cleaned up.
- catch unset [info globals HM$win.form*]
-
- HMinit_state $win
- return HM$win
-}
-
-# initialize the window's state array
-# Parameters beginning with S_ are NOT reset
-# adjust_size: global font size adjuster
-# unknown: character to use for unknown entities
-# tab: tab stop (in cm)
-# stop: enabled to stop processing
-# update: how many tags between update calls
-# tags: number of tags processed so far
-# symbols: Symbols to use on un-ordered lists
-
-proc HMinit_state {win} {
- upvar #0 HM$win var
- array set tmp [array get var S_*]
- catch {unset var}
- array set var {
- stop 0
- tags 0
- fill 0
- list list
- S_adjust_size 0
- S_tab 1.0
- S_unknown \xb7
- S_update 10
- S_symbols O*=+-o\xd7\xb0>:\xb7
- S_insert Insert
- }
- array set var [array get tmp]
-}
-
-# alter the parameters of the text state
-# this allows an application to over-ride the default settings
-# it is called as: HMset_state -param value -param value ...
-
-array set HMparam_map {
- -update S_update
- -tab S_tab
- -unknown S_unknown
- -stop S_stop
- -size S_adjust_size
- -symbols S_symbols
- -insert S_insert
-}
-
-proc HMset_state {win args} {
- upvar #0 HM$win var
- global HMparam_map
- set bad 0
- if {[catch {array set params $args}]} {return 0}
- foreach i [array names params] {
- incr bad [catch {set var($HMparam_map($i)) $params($i)}]
- }
- return [expr $bad == 0]
-}
-
-############################################
-# manage the display of html
-
-# HMrender gets called for every html tag
-# win: The name of the text widget to render into
-# tag: The html tag (in arbitrary case)
-# not: a "/" or the empty string
-# param: The un-interpreted parameter list
-# text: The plain text until the next html tag
-
-proc HMrender {win tag not param text} {
- upvar #0 HM$win var
- if {$var(stop)} return
- global HMtag_map HMinsert_map HMlist_elements
- set tag [string tolower $tag]
- set text [HMmap_esc $text]
-
- # manage compact rendering of lists
- if {[info exists HMlist_elements($tag)]} {
- set list "list [expr {[HMextract_param $param compact] ? "compact" : "list"}]"
- } else {
- set list ""
- }
-
- # Allow text to be diverted to a different window (for tables)
- # this is not currently used
- if {[info exists var(divert)]} {
- set win $var(divert)
- upvar #0 HM$win var
- }
-
- # adjust (push or pop) tag state
- catch {HMstack $win $not "$HMtag_map($tag) $list"}
-
- # insert white space (with current font)
- # adding white space can get a bit tricky. This isn't quite right
- set bad [catch {$win insert $var(S_insert) $HMinsert_map($not$tag) "space $var(font)"}]
- if {!$bad && [lindex $var(fill) end]} {
- set text [string trimleft $text]
- }
-
- # to fill or not to fill
- if {[lindex $var(fill) end]} {
- set text [HMzap_white $text]
- }
-
- # generic mark hook
- catch {HMmark $not$tag $win $param text} err
-
- # do any special tag processing
- catch {HMtag_$not$tag $win $param text} msg
-
-
- # add the text with proper tags
-
- set tags [HMcurrent_tags $win]
- $win insert $var(S_insert) $text $tags
-
- # We need to do an update every so often to insure interactive response.
- # This can cause us to re-enter the event loop, and cause recursive
- # invocations of HMrender, so we need to be careful.
- if {!([incr var(tags)] % $var(S_update))} {
- update
- }
-}
-
-# html tags requiring special processing
-# Procs of the form HMtag_<tag> or HMtag_</tag> get called just before
-# the text for this tag is displayed. These procs are called inside a
-# "catch" so it is OK to fail.
-# win: The name of the text widget to render into
-# param: The un-interpreted parameter list
-# text: A pass-by-reference name of the plain text until the next html tag
-# Tag commands may change this to affect what text will be inserted
-# next.
-
-# A pair of pseudo tags are added automatically as the 1st and last html
-# tags in the document. The default is <HMstart> and </HMstart>.
-# Append enough blank space at the end of the text widget while
-# rendering so HMgoto can place the target near the top of the page,
-# then remove the extra space when done rendering.
-
-proc HMtag_hmstart {win param text} {
- upvar #0 HM$win var
- $win mark gravity $var(S_insert) left
- $win insert end "\n " last
- $win mark gravity $var(S_insert) right
-}
-
-proc HMtag_/hmstart {win param text} {
- $win delete last.first end
-}
-
-# put the document title in the window banner, and remove the title text
-# from the document
-
-proc HMtag_title {win param text} {
- upvar $text data
- wm title [winfo toplevel $win] $data
- set data ""
-}
-
-proc HMtag_hr {win param text} {
- upvar #0 HM$win var
- $win insert $var(S_insert) "\n" space "\n" thin "\t" "thin hr" "\n" thin
-}
-
-# list element tags
-
-proc HMtag_ol {win param text} {
- upvar #0 HM$win var
- set var(count$var(level)) 0
-}
-
-proc HMtag_ul {win param text} {
- upvar #0 HM$win var
- catch {unset var(count$var(level))}
-}
-
-proc HMtag_menu {win param text} {
- upvar #0 HM$win var
- set var(menu) ->
- set var(compact) 1
-}
-
-proc HMtag_/menu {win param text} {
- upvar #0 HM$win var
- catch {unset var(menu)}
- catch {unset var(compact)}
-}
-
-proc HMtag_dt {win param text} {
- upvar #0 HM$win var
- upvar $text data
- set level $var(level)
- incr level -1
- $win insert $var(S_insert) "$data" \
- "hi [lindex $var(list) end] indent$level $var(font)"
- set data {}
-}
-
-proc HMtag_li {win param text} {
- upvar #0 HM$win var
- set level $var(level)
- incr level -1
- set x [string index $var(S_symbols)+-+-+-+-" $level]
- catch {set x [incr var(count$level)]}
- catch {set x $var(menu)}
- $win insert $var(S_insert) \t$x\t "mark [lindex $var(list) end] indent$level $var(font)"
-}
-
-# Manage hypertext "anchor" links. A link can be either a source (href)
-# a destination (name) or both. If its a source, register it via a callback,
-# and set its default behavior. If its a destination, check to see if we need
-# to go there now, as a result of a previous HMgoto request. If so, schedule
-# it to happen with the closing </a> tag, so we can highlight the text up to
-# the </a>.
-
-proc HMtag_a {win param text} {
- upvar #0 HM$win var
-
- # a source
-
- if {[HMextract_param $param href]} {
- set var(Tref) [list L:$href]
- HMstack $win "" "Tlink link"
- HMlink_setup $win $href
- }
-
- # a destination
-
- if {[HMextract_param $param name]} {
- set var(Tname) [list N:$name]
- HMstack $win "" "Tanchor anchor"
- $win mark set N:$name "$var(S_insert) - 1 chars"
- $win mark gravity N:$name left
- if {[info exists var(goto)] && $var(goto) == $name} {
- unset var(goto)
- set var(going) $name
- }
- }
-}
-
-# The application should call here with the fragment name
-# to cause the display to go to this spot.
-# If the target exists, go there (and do the callback),
-# otherwise schedule the goto to happen when we see the reference.
-
-proc HMgoto {win where {callback HMwent_to}} {
- upvar #0 HM$win var
- if {[regexp N:$where [$win mark names]]} {
- $win see N:$where
- update
- eval $callback $win [list $where]
- return 1
- } else {
- set var(goto) $where
- return 0
- }
-}
-
-# We actually got to the spot, so highlight it!
-# This should/could be replaced by the application
-# We'll flash it orange a couple of times.
-
-proc HMwent_to {win where {count 0} {color orange}} {
- upvar #0 HM$win var
- if {$count > 5} return
- catch {$win tag configure N:$where -foreground $color}
- update
- after 200 [list HMwent_to $win $where [incr count] \
- [expr {$color=="orange" ? "" : "orange"}]]
-}
-
-proc HMtag_/a {win param text} {
- upvar #0 HM$win var
- if {[info exists var(Tref)]} {
- unset var(Tref)
- HMstack $win / "Tlink link"
- }
-
- # goto this link, then invoke the call-back.
-
- if {[info exists var(going)]} {
- $win yview N:$var(going)
- update
- HMwent_to $win $var(going)
- unset var(going)
- }
-
- if {[info exists var(Tname)]} {
- unset var(Tname)
- HMstack $win / "Tanchor anchor"
- }
-}
-
-# Inline Images
-# This interface is subject to change
-# Most of the work is getting around a limitation of TK that prevents
-# setting the size of a label to a widthxheight in pixels
-#
-# Images have the following parameters:
-# align: top,middle,bottom
-# alt: alternate text
-# ismap: A clickable image map
-# src: The URL link
-# Netscape supports (and so do we)
-# width: A width hint (in pixels)
-# height: A height hint (in pixels)
-# border: The size of the window border
-
-proc HMtag_img {win param text} {
- upvar #0 HM$win var
-
- # get alignment
- array set align_map {top top middle center bottom bottom}
- set align bottom ;# The spec isn't clear what the default should be
- HMextract_param $param align
- catch {set align $align_map([string tolower $align])}
-
- # get alternate text
- set alt "<image>"
- HMextract_param $param alt
- set alt [HMmap_esc $alt]
-
- # get the border width
- set border 1
- HMextract_param $param border
-
- # see if we have an image size hint
- # If so, make a frame the "hint" size to put the label in
- # otherwise just make the label
- set item $win.$var(tags)
- # catch {destroy $item}
- if {[HMextract_param $param width] && [HMextract_param $param height]} {
- frame $item -width $width -height $height
- pack propagate $item 0
- set label $item.label
- label $label
- pack $label -expand 1 -fill both
- } else {
- set label $item
- label $label
- }
-
- $label configure -relief ridge -fg orange -text $alt
- catch {$label configure -bd $border}
- $win window create $var(S_insert) -align $align -window $item -pady 2 -padx 2
-
- # add in all the current tags (this is overkill)
- set tags [HMcurrent_tags $win]
- foreach tag $tags {
- $win tag add $tag $item
- }
-
- # set imagemap callbacks
- if {[HMextract_param $param ismap]} {
- # regsub -all {[^L]*L:([^ ]*).*} $tags {\1} link
- set link [lindex $tags [lsearch -glob $tags L:*]]
- regsub L: $link {} link
- global HMevents
- regsub -all {%} $link {%%} link2
- foreach i [array names HMevents] {
- bind $label <$i> "catch \{%W configure $HMevents($i)\}"
- }
- bind $label <1> "+HMlink_callback $win $link2?%x,%y"
- }
-
- # now callback to the application
- set src ""
- HMextract_param $param src
- HMset_image $win $label $src
- return $label ;# used by the forms package for input_image types
-}
-
-# The app needs to supply one of these
-proc HMset_image {win handle src} {
- HMgot_image $handle "can't get\n$src"
-}
-
-# When the image is available, the application should call back here.
-# If we have the image, put it in the label, otherwise display the error
-# message. If we don't get a callback, the "alt" text remains.
-# if we have a clickable image, arrange for a callback
-
-proc HMgot_image {win image_error} {
- # if we're in a frame turn on geometry propogation
- if {[winfo name $win] == "label"} {
- pack propagate [winfo parent $win] 1
- }
- if {[catch {$win configure -image $image_error}]} {
- $win configure -image {}
- $win configure -text $image_error
- }
-}
-
-# Sample hypertext link callback routine - should be replaced by app
-# This proc is called once for each <A> tag.
-# Applications can overwrite this procedure, as required, or
-# replace the HMevents array
-# win: The name of the text widget to render into
-# href: The HREF link for this <a> tag.
-
-array set HMevents {
- Enter {-borderwidth 2 -relief raised }
- Leave {-borderwidth 2 -relief flat }
- 1 {-borderwidth 2 -relief sunken}
- ButtonRelease-1 {-borderwidth 2 -relief raised}
-}
-
-# We need to escape any %'s in the href tag name so the bind command
-# doesn't try to substitute them.
-
-proc HMlink_setup {win href} {
- global HMevents
- regsub -all {%} $href {%%} href2
- foreach i [array names HMevents] {
- eval {$win tag bind L:$href <$i>} \
- \{$win tag configure \{L:$href2\} $HMevents($i)\}
- }
-}
-
-# generic link-hit callback
-# This gets called upon button hits on hypertext links
-# Applications are expected to supply ther own HMlink_callback routine
-# win: The name of the text widget to render into
-# x,y: The cursor position at the "click"
-
-proc HMlink_hit {win x y} {
- set tags [$win tag names @$x,$y]
- set link [lindex $tags [lsearch -glob $tags L:*]]
- # regsub -all {[^L]*L:([^ ]*).*} $tags {\1} link
- regsub L: $link {} link
- HMlink_callback $win $link
-}
-
-# replace this!
-# win: The name of the text widget to render into
-# href: The HREF link for this <a> tag.
-
-proc HMlink_callback {win href} {
- puts "Got hit on $win, link $href"
-}
-
-# extract a value from parameter list (this needs a re-do)
-# returns "1" if the keyword is found, "0" otherwise
-# param: A parameter list. It should alredy have been processed to
-# remove any entity references
-# key: The parameter name
-# val: The variable to put the value into (use key as default)
-
-proc HMextract_param {param key {val ""}} {
-
- if {$val == ""} {
- upvar $key result
- } else {
- upvar $val result
- }
- set ws " \n\r"
-
- # look for name=value combinations. Either (') or (") are valid delimeters
- if {
- [regsub -nocase [format {.*%s[%s]*=[%s]*"([^"]*).*} $key $ws $ws] $param {\1} value] ||
- [regsub -nocase [format {.*%s[%s]*=[%s]*'([^']*).*} $key $ws $ws] $param {\1} value] ||
- [regsub -nocase [format {.*%s[%s]*=[%s]*([^%s]+).*} $key $ws $ws $ws] $param {\1} value] } {
- set result $value
- return 1
- }
-
- # now look for valueless names
- # I should strip out name=value pairs, so we don't end up with "name"
- # inside the "value" part of some other key word - some day
-
- set bad \[^a-zA-Z\]+
- if {[regexp -nocase "$bad$key$bad" -$param-]} {
- return 1
- } else {
- return 0
- }
-}
-
-# These next two routines manage the display state of the page.
-
-# Push or pop tags to/from stack.
-# Each orthogonal text property has its own stack, stored as a list.
-# The current (most recent) tag is the last item on the list.
-# Push is {} for pushing and {/} for popping
-
-proc HMstack {win push list} {
- upvar #0 HM$win var
- array set tags $list
- if {$push == ""} {
- foreach tag [array names tags] {
- lappend var($tag) $tags($tag)
- }
- } else {
- foreach tag [array names tags] {
- # set cnt [regsub { *[^ ]+$} $var($tag) {} var($tag)]
- set var($tag) [lreplace $var($tag) end end]
- }
- }
-}
-
-# extract set of current text tags
-# tags starting with T map directly to text tags, all others are
-# handled specially. There is an application callback, HMset_font
-# to allow the application to do font error handling
-
-proc HMcurrent_tags {win} {
- upvar #0 HM$win var
- set font font
- foreach i {family size weight style} {
- set $i [lindex $var($i) end]
- append font :[set $i]
- }
- set xfont [HMx_font $family $size $weight $style $var(S_adjust_size)]
- HMset_font $win $font $xfont
- set indent [llength $var(indent)]
- incr indent -1
- lappend tags $font indent$indent
- foreach tag [array names var T*] {
- lappend tags [lindex $var($tag) end] ;# test
- }
- set var(font) $font
- set var(xfont) [$win tag cget $font -font]
- set var(level) $indent
- return $tags
-}
-
-# allow the application to do do better font management
-# by overriding this procedure
-
-proc HMset_font {win tag font} {
- catch {$win tag configure $tag -font $font} msg
-}
-
-# generate an X font name
-proc HMx_font {family size weight style {adjust_size 0}} {
- catch {incr size $adjust_size}
- return "-*-$family-$weight-$style-normal-*-*-${size}0-*-*-*-*-*-*"
-}
-
-# Optimize HMrender (hee hee)
-# This is experimental
-
-proc HMoptimize {} {
- regsub -all "\n\[ \]*#\[^\n\]*" [info body HMrender] {} body
- regsub -all ";\[ \]*#\[^\n]*" $body {} body
- regsub -all "\n\n+" $body \n body
- proc HMrender {win tag not param text} $body
-}
-############################################
-# Turn HTML into TCL commands
-# html A string containing an html document
-# cmd A command to run for each html tag found
-# start The name of the dummy html start/stop tags
-
-proc HMparse_html {html {cmd HMtest_parse} {start hmstart}} {
- regsub -all \{ $html {\&ob;} html
- regsub -all \} $html {\&cb;} html
- set w " \t\r\n" ;# white space
- proc HMcl x {return "\[$x\]"}
- set exp <(/?)([HMcl ^$w>]+)[HMcl $w]*([HMcl ^>]*)>
- set sub "\}\n$cmd {\\2} {\\1} {\\3} \{"
- regsub -all $exp $html $sub html
- eval "$cmd {$start} {} {} \{ $html \}"
- eval "$cmd {$start} / {} {}"
-}
-
-proc HMtest_parse {command tag slash text_after_tag} {
- puts "==> $command $tag $slash $text_after_tag"
-}
-
-# Convert multiple white space into a single space
-
-proc HMzap_white {data} {
- regsub -all "\[ \t\r\n\]+" $data " " data
- return $data
-}
-
-# find HTML escape characters of the form &xxx;
-
-proc HMmap_esc {text} {
- if {![regexp & $text]} {return $text}
- regsub -all {([][$\\])} $text {\\\1} new
- regsub -all {&#([0-9][0-9]?[0-9]?);?} \
- $new {[format %c [scan \1 %d tmp;set tmp]]} new
- regsub -all {&([a-zA-Z]+);?} $new {[HMdo_map \1]} new
- return [subst $new]
-}
-
-# convert an HTML escape sequence into character
-
-proc HMdo_map {text {unknown ?}} {
- global HMesc_map
- set result $unknown
- catch {set result $HMesc_map($text)}
- return $result
-}
-
-# table of escape characters (ISO latin-1 esc's are in a different table)
-
-array set HMesc_map {
- lt < gt > amp & quot \" copy \xa9
- reg \xae ob \x7b cb \x7d nbsp \xa0
-}
-#############################################################
-# ISO Latin-1 escape codes
-
-array set HMesc_map {
- nbsp \xa0 iexcl \xa1 cent \xa2 pound \xa3 curren \xa4
- yen \xa5 brvbar \xa6 sect \xa7 uml \xa8 copy \xa9
- ordf \xaa laquo \xab not \xac shy \xad reg \xae
- hibar \xaf deg \xb0 plusmn \xb1 sup2 \xb2 sup3 \xb3
- acute \xb4 micro \xb5 para \xb6 middot \xb7 cedil \xb8
- sup1 \xb9 ordm \xba raquo \xbb frac14 \xbc frac12 \xbd
- frac34 \xbe iquest \xbf Agrave \xc0 Aacute \xc1 Acirc \xc2
- Atilde \xc3 Auml \xc4 Aring \xc5 AElig \xc6 Ccedil \xc7
- Egrave \xc8 Eacute \xc9 Ecirc \xca Euml \xcb Igrave \xcc
- Iacute \xcd Icirc \xce Iuml \xcf ETH \xd0 Ntilde \xd1
- Ograve \xd2 Oacute \xd3 Ocirc \xd4 Otilde \xd5 Ouml \xd6
- times \xd7 Oslash \xd8 Ugrave \xd9 Uacute \xda Ucirc \xdb
- Uuml \xdc Yacute \xdd THORN \xde szlig \xdf agrave \xe0
- aacute \xe1 acirc \xe2 atilde \xe3 auml \xe4 aring \xe5
- aelig \xe6 ccedil \xe7 egrave \xe8 eacute \xe9 ecirc \xea
- euml \xeb igrave \xec iacute \xed icirc \xee iuml \xef
- eth \xf0 ntilde \xf1 ograve \xf2 oacute \xf3 ocirc \xf4
- otilde \xf5 ouml \xf6 divide \xf7 oslash \xf8 ugrave \xf9
- uacute \xfa ucirc \xfb uuml \xfc yacute \xfd thorn \xfe
- yuml \xff
-}
-
-##########################################################
-# html forms management commands
-
-# As each form element is located, it is created and rendered. Additional
-# state is stored in a form specific global variable to be processed at
-# the end of the form, including the "reset" and "submit" options.
-# Remember, there can be multiple forms existing on multiple pages. When
-# HTML tables are added, a single form could be spread out over multiple
-# text widgets, which makes it impractical to hang the form state off the
-# HM$win structure. We don't need to check for the existance of required
-# parameters, we just "fail" and get caught in HMrender
-
-# This causes line breaks to be preserved in the inital values
-# of text areas
-array set HMtag_map {
- textarea {fill 0}
-}
-
-##########################################################
-# html isindex tag. Although not strictly forms, they're close enough
-# to be in this file
-
-# is-index forms
-# make a frame with a label, entry, and submit button
-
-proc HMtag_isindex {win param text} {
- upvar #0 HM$win var
-
- set item $win.$var(tags)
- if {[winfo exists $item]} {
- destroy $item
- }
- frame $item -relief ridge -bd 3
- set prompt "Enter search keywords here"
- HMextract_param $param prompt
- label $item.label -text [HMmap_esc $prompt] -font $var(xfont)
- entry $item.entry
- bind $item.entry <Return> "$item.submit invoke"
- button $item.submit -text search -font $var(xfont) -command \
- [format {HMsubmit_index %s {%s} [HMmap_reply [%s get]]} \
- $win $param $item.entry]
- pack $item.label -side top
- pack $item.entry $item.submit -side left
-
- # insert window into text widget
-
- $win insert $var(S_insert) \n isindex
- HMwin_install $win $item
- $win insert $var(S_insert) \n isindex
- bind $item <Visibility> {focus %W.entry}
-}
-
-# This is called when the isindex form is submitted.
-# The default version calls HMlink_callback. Isindex tags should either
-# be deprecated, or fully supported (e.g. they need an href parameter)
-
-proc HMsubmit_index {win param text} {
- HMlink_callback $win ?$text
-}
-
-# initialize form state. All of the state for this form is kept
-# in a global array whose name is stored in the form_id field of
-# the main window array.
-# Parameters: ACTION, METHOD, ENCTYPE
-
-proc HMtag_form {win param text} {
- upvar #0 HM$win var
-
- # create a global array for the form
- set id HM$win.form$var(tags)
- upvar #0 $id form
-
- # missing /form tag, simulate it
- if {[info exists var(form_id)]} {
- puts "Missing end-form tag !!!! $var(form_id)"
- HMtag_/form $win {} {}
- }
- catch {unset form}
- set var(form_id) $id
-
- set form(param) $param ;# form initial parameter list
- set form(reset) "" ;# command to reset the form
- set form(reset_button) "" ;# list of all reset buttons
- set form(submit) "" ;# command to submit the form
- set form(submit_button) "" ;# list of all submit buttons
-}
-
-# Where we're done try to get all of the state into the widgets so
-# we can free up the form structure here. Unfortunately, we can't!
-
-proc HMtag_/form {win param text} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
-
- # make submit button entries for all radio buttons
- foreach name [array names form radio_*] {
- regsub radio_ $name {} name
- lappend form(submit) [list $name \$form(radio_$name)]
- }
-
- # process the reset button(s)
-
- foreach item $form(reset_button) {
- $item configure -command $form(reset)
- }
-
- # no submit button - add one
- if {$form(submit_button) == ""} {
- HMinput_submit $win {}
- }
-
- # process the "submit" command(s)
- # each submit button could have its own name,value pair
-
- foreach item $form(submit_button) {
- set submit $form(submit)
- catch {lappend submit $form(submit_$item)}
- $item configure -command \
- [list HMsubmit_button $win $var(form_id) $form(param) \
- $submit]
- }
-
- # unset all unused fields here
- unset form(reset) form(submit) form(reset_button) form(submit_button)
- unset var(form_id)
-}
-
-###################################################################
-# handle form input items
-# each item type is handled in a separate procedure
-# Each "type" procedure needs to:
-# - create the window
-# - initialize it
-# - add the "submit" and "reset" commands onto the proper Q's
-# "submit" is subst'd
-# "reset" is eval'd
-
-proc HMtag_input {win param text} {
- upvar #0 HM$win var
-
- set type text ;# the default
- HMextract_param $param type
- set type [string tolower $type]
- if {[catch {HMinput_$type $win $param} err]} {
- puts stderr $err
- }
-}
-
-# input type=text
-# parameters NAME (reqd), MAXLENGTH, SIZE, VALUE
-
-proc HMinput_text {win param {show {}}} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
-
- # make the entry
- HMextract_param $param name ;# required
- set item $win.input_text,$var(tags)
- set size 20; HMextract_param $param size
- set maxlength 0; HMextract_param $param maxlength
- entry $item -width $size -show $show
-
- # set the initial value
- set value ""; HMextract_param $param value
- $item insert 0 $value
-
- # insert the entry
- HMwin_install $win $item
-
- # set the "reset" and "submit" commands
- append form(reset) ";$item delete 0 end;$item insert 0 [list $value]"
- lappend form(submit) [list $name "\[$item get]"]
-
- # handle the maximum length (broken - no way to cleanup bindtags state)
- if {$maxlength} {
- bindtags $item "[bindtags $item] max$maxlength"
- bind max$maxlength <KeyPress> "%W delete $maxlength end"
- }
-}
-
-# password fields - same as text, only don't show data
-# parameters NAME (reqd), MAXLENGTH, SIZE, VALUE
-
-proc HMinput_password {win param} {
- HMinput_text $win $param *
-}
-
-# checkbuttons are missing a "get" option, so we must use a global
-# variable to store the value.
-# Parameters NAME, VALUE, (reqd), CHECKED
-
-proc HMinput_checkbox {win param} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
-
- HMextract_param $param name
- HMextract_param $param value
-
- # Set the global variable, don't use the "form" alias as it is not
- # defined in the global scope of the button
- set variable $var(form_id)(check_$var(tags))
- set item $win.input_checkbutton,$var(tags)
- checkbutton $item -variable $variable -off {} -on $value -text " "
- if {[HMextract_param $param checked]} {
- $item select
- append form(reset) ";$item select"
- } else {
- append form(reset) ";$item deselect"
- }
-
- HMwin_install $win $item
- lappend form(submit) [list $name \$form(check_$var(tags))]
-}
-
-# radio buttons. These are like check buttons, but only one can be selected
-
-proc HMinput_radio {win param} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
-
- HMextract_param $param name
- HMextract_param $param value
-
- set first [expr ![info exists form(radio_$name)]]
- set variable $var(form_id)(radio_$name)
- set variable $var(form_id)(radio_$name)
- set item $win.input_radiobutton,$var(tags)
- radiobutton $item -variable $variable -value $value -text " "
-
- HMwin_install $win $item
-
- if {$first || [HMextract_param $param checked]} {
- $item select
- append form(reset) ";$item select"
- } else {
- append form(reset) ";$item deselect"
- }
-
- # do the "submit" actions in /form so we only end up with 1 per button grouping
- # contributing to the submission
-}
-
-# hidden fields, just append to the "submit" data
-# params: NAME, VALUE (reqd)
-
-proc HMinput_hidden {win param} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
- HMextract_param $param name
- HMextract_param $param value
- lappend form(submit) [list $name $value]
-}
-
-# handle input images. The spec isn't very clear on these, so I'm not
-# sure its quite right
-# Use std image tag, only set up our own callbacks
-# (e.g. make sure ismap isn't set)
-# params: NAME, SRC (reqd) ALIGN
-
-proc HMinput_image {win param} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
- HMextract_param $param name
- set name ;# barf if no name is specified
- set item [HMtag_img $win $param {}]
- $item configure -relief raised -bd 2 -bg blue
-
- # make a dummy "submit" button, and invoke it to send the form.
- # We have to get the %x,%y in the value somehow, so calculate it during
- # binding, and save it in the form array for later processing
-
- set submit $win.dummy_submit,$var(tags)
- if {[winfo exists $submit]} {
- destroy $submit
- }
- button $submit -takefocus 0;# this never gets mapped!
- lappend form(submit_button) $submit
- set form(submit_$submit) [list $name $name.\$form(X).\$form(Y)]
-
- $item configure -takefocus 1
- bind $item <FocusIn> "catch \{$win see $item\}"
- bind $item <1> "$item configure -relief sunken"
- bind $item <Return> "
- set $var(form_id)(X) 0
- set $var(form_id)(Y) 0
- $submit invoke
- "
- bind $item <ButtonRelease-1> "
- set $var(form_id)(X) %x
- set $var(form_id)(Y) %y
- $item configure -relief raised
- $submit invoke
- "
-}
-
-# Set up the reset button. Wait for the /form to attach
-# the -command option. There could be more that 1 reset button
-# params VALUE
-
-proc HMinput_reset {win param} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
-
- set value reset
- HMextract_param $param value
-
- set item $win.input_reset,$var(tags)
- button $item -text [HMmap_esc $value]
- HMwin_install $win $item
- lappend form(reset_button) $item
-}
-
-# Set up the submit button. Wait for the /form to attach
-# the -command option. There could be more that 1 submit button
-# params: NAME, VALUE
-
-proc HMinput_submit {win param} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
-
- HMextract_param $param name
- set value submit
- HMextract_param $param value
- set item $win.input_submit,$var(tags)
- button $item -text [HMmap_esc $value] -fg blue
- HMwin_install $win $item
- lappend form(submit_button) $item
- # need to tie the "name=value" to this button
- # save the pair and do it when we finish the submit button
- catch {set form(submit_$item) [list $name $value]}
-}
-
-#########################################################################
-# selection items
-# They all go into a list box. We don't what to do with the listbox until
-# we know how many items end up in it. Gather up the data for the "options"
-# and finish up in the /select tag
-# params: NAME (reqd), MULTIPLE, SIZE
-
-proc HMtag_select {win param text} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
-
- HMextract_param $param name
- set size 5; HMextract_param $param size
- set form(select_size) $size
- set form(select_name) $name
- set form(select_values) "" ;# list of values to submit
- if {[HMextract_param $param multiple]} {
- set mode multiple
- } else {
- set mode single
- }
- set item $win.select,$var(tags)
- frame $item
- set form(select_frame) $item
- listbox $item.list -selectmode $mode -width 0 -exportselection 0
- HMwin_install $win $item
-}
-
-# select options
-# The values returned in the query may be different from those
-# displayed in the listbox, so we need to keep a separate list of
-# query values.
-# form(select_default) - contains the default query value
-# form(select_frame) - name of the listbox's containing frame
-# form(select_values) - list of query values
-# params: VALUE, SELECTED
-
-proc HMtag_option {win param text} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
- upvar $text data
- set frame $form(select_frame)
-
- # set default option (or options)
- if {[HMextract_param $param selected]} {
- lappend form(select_default) [$form(select_frame).list size]
- }
- set value [string trimright $data " \n"]
- $frame.list insert end $value
- HMextract_param $param value
- lappend form(select_values) $value
- set data ""
-}
-
-# do most of the work here!
-# if SIZE>1, make the listbox. Otherwise make a "drop-down"
-# listbox with a label in it
-# If the # of items > size, add a scroll bar
-# This should probably be broken up into callbacks to make it
-# easier to override the "look".
-
-proc HMtag_/select {win param text} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
- set frame $form(select_frame)
- set size $form(select_size)
- set items [$frame.list size]
-
- # set the defaults and reset button
- append form(reset) ";$frame.list selection clear 0 $items"
- if {[info exists form(select_default)]} {
- foreach i $form(select_default) {
- $frame.list selection set $i
- append form(reset) ";$frame.list selection set $i"
- }
- } else {
- $frame.list selection set 0
- append form(reset) ";$frame.list selection set 0"
- }
-
- # set up the submit button. This is the general case. For single
- # selections we could be smarter
-
- for {set i 0} {$i < $size} {incr i} {
- set value [format {[expr {[%s selection includes %s] ? {%s} : {}}]} \
- $frame.list $i [lindex $form(select_values) $i]]
- lappend form(submit) [list $form(select_name) $value]
- }
-
- # show the listbox - no scroll bar
-
- if {$size > 1 && $items <= $size} {
- $frame.list configure -height $items
- pack $frame.list
-
- # Listbox with scrollbar
-
- } elseif {$size > 1} {
- scrollbar $frame.scroll -command "$frame.list yview" \
- -orient v -takefocus 0
- $frame.list configure -height $size \
- -yscrollcommand "$frame.scroll set"
- pack $frame.list $frame.scroll -side right -fill y
-
- # This is a joke!
-
- } else {
- scrollbar $frame.scroll -command "$frame.list yview" \
- -orient h -takefocus 0
- $frame.list configure -height 1 \
- -yscrollcommand "$frame.scroll set"
- pack $frame.list $frame.scroll -side top -fill x
- }
-
- # cleanup
-
- foreach i [array names form select_*] {
- unset form($i)
- }
-}
-
-# do a text area (multi-line text)
-# params: COLS, NAME, ROWS (all reqd, but default rows and cols anyway)
-
-proc HMtag_textarea {win param text} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
- upvar $text data
-
- set rows 5; HMextract_param $param rows
- set cols 30; HMextract_param $param cols
- HMextract_param $param name
- set item $win.textarea,$var(tags)
- frame $item
- text $item.text -width $cols -height $rows -wrap none \
- -yscrollcommand "$item.scroll set" -padx 3 -pady 3
- scrollbar $item.scroll -command "$item.text yview" -orient v
- $item.text insert 1.0 $data
- HMwin_install $win $item
- pack $item.text $item.scroll -side right -fill y
- lappend form(submit) [list $name "\[$item.text get 0.0 end]"]
- append form(reset) ";$item.text delete 1.0 end; \
- $item.text insert 1.0 [list $data]"
- set data ""
-}
-
-# procedure to install windows into the text widget
-# - win: name of the text widget
-# - item: name of widget to install
-
-proc HMwin_install {win item} {
- upvar #0 HM$win var
- $win window create $var(S_insert) -window $item -align bottom
- $win tag add indent$var(level) $item
- set focus [expr {[winfo class $item] != "Frame"}]
- $item configure -takefocus $focus
- bind $item <FocusIn> "$win see $item"
-}
-
-#####################################################################
-# Assemble and submit the query
-# each list element in "stuff" is a name/value pair
-# - The names are the NAME parameters of the various fields
-# - The values get run through "subst" to extract the values
-# - We do the user callback with the list of name value pairs
-
-proc HMsubmit_button {win form_id param stuff} {
- upvar #0 HM$win var
- upvar #0 $form_id form
- set query ""
- foreach pair $stuff {
- set value [subst [lindex $pair 1]]
- if {$value != ""} {
- set item [lindex $pair 0]
- lappend query $item $value
- }
- }
- # this is the user callback.
- HMsubmit_form $win $param $query
-}
-
-# sample user callback for form submission
-# should be replaced by the application
-# Sample version generates a string suitable for http
-
-proc HMsubmit_form {win param query} {
- set result ""
- set sep ""
- foreach i $query {
- append result $sep [HMmap_reply $i]
- if {$sep != "="} {set sep =} {set sep &}
- }
- puts $result
-}
-
-# do x-www-urlencoded character mapping
-# The spec says: "non-alphanumeric characters are replaced by '%HH'"
-
-set HMalphanumeric a-zA-Z0-9 ;# definition of alphanumeric character class
-for {set i 1} {$i <= 256} {incr i} {
- set c [format %c $i]
- if {![string match \[$HMalphanumeric\] $c]} {
- set HMform_map($c) %[format %.2x $i]
- }
-}
-
-# These are handled specially
-array set HMform_map {
- " " + \n %0d%0a
-}
-
-# 1 leave alphanumerics characters alone
-# 2 Convert every other character to an array lookup
-# 3 Escape constructs that are "special" to the tcl parser
-# 4 "subst" the result, doing all the array substitutions
-
-proc HMmap_reply {string} {
- global HMform_map HMalphanumeric
- regsub -all \[^$HMalphanumeric\] $string {$HMform_map(&)} string
- regsub -all \n $string {\\n} string
- regsub -all \t $string {\\t} string
- regsub -all {[][{})\\]\)} $string {\\&} string
- return [subst $string]
-}
-
-# convert a x-www-urlencoded string int a a list of name/value pairs
-
-# 1 convert a=b&c=d... to {a} {b} {c} {d}...
-# 2, convert + to " "
-# 3, convert %xx to char equiv
-
-proc HMcgiDecode {data} {
- set data [split $data "&="]
- foreach i $data {
- lappend result [cgiMap $i]
- }
- return $result
-}
-
-proc HMcgiMap {data} {
- regsub -all {\+} $data " " data
-
- if {[regexp % $data]} {
- regsub -all {([][$\\])} $data {\\\1} data
- regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data
- return [subst $data]
- } else {
- return $data
- }
-}
-
-# There is a bug in the tcl library focus routines that prevents focus
-# from every reaching an un-viewable window. Use our *own*
-# version of the library routine, until the bug is fixed, make sure we
-# over-ride the library version, and not the otherway around
-
-auto_load tkFocusOK
-proc tkFocusOK w {
- set code [catch {$w cget -takefocus} value]
- if {($code == 0) && ($value != "")} {
- if {$value == 0} {
- return 0
- } elseif {$value == 1} {
- return 1
- } else {
- set value [uplevel #0 $value $w]
- if {$value != ""} {
- return $value
- }
- }
- }
- set code [catch {$w cget -state} value]
- if {($code == 0) && ($value == "disabled")} {
- return 0
- }
- regexp Key|Focus "[bind $w] [bind [winfo class $w]]"
-}
Copied: grass/trunk/lib/form/html_library.tcl (from rev 35193, grass/trunk/lib/form/html_library.tcl)
===================================================================
--- grass/trunk/lib/form/html_library.tcl (rev 0)
+++ grass/trunk/lib/form/html_library.tcl 2009-01-04 15:47:39 UTC (rev 35199)
@@ -0,0 +1,1417 @@
+# Simple HTML display library by Stephen Uhler (stephen.uhler at sun.com)
+# Copyright (c) 1995 by Sun Microsystems
+# Version 0.3 Fri Sep 1 10:47:17 PDT 1995
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# To use this package, create a text widget (say, .text)
+# and set a variable full of html, (say $html), and issue:
+# HMinit_win .text
+# HMparse_html $html "HMrender .text"
+# You also need to supply the routine:
+# proc HMlink_callback {win href} { ...}
+# win: The name of the text widget
+# href The name of the link
+# which will be called anytime the user "clicks" on a link.
+# The supplied version just prints the link to stdout.
+# In addition, if you wish to use embedded images, you will need to write
+# proc HMset_image {handle src}
+# handle an arbitrary handle (not really)
+# src The name of the image
+# Which calls
+# HMgot_image $handle $image
+# with the TK image.
+#
+# To return a "used" text widget to its initialized state, call:
+# HMreset_win .text
+# See "sample.tcl" for sample usage
+##################################################################
+############################################
+# mapping of html tags to text tag properties
+# properties beginning with "T" map directly to text tags
+
+# These are Defined in HTML 2.0
+
+array set HMtag_map {
+ b {weight bold}
+ blockquote {style i indent 1 Trindent rindent}
+ bq {style i indent 1 Trindent rindent}
+ cite {style i}
+ code {family courier}
+ dfn {style i}
+ dir {indent 1}
+ dl {indent 1}
+ em {style i}
+ h1 {size 24 weight bold}
+ h2 {size 22}
+ h3 {size 20}
+ h4 {size 18}
+ h5 {size 16}
+ h6 {style i}
+ i {style i}
+ kbd {family courier weight bold}
+ menu {indent 1}
+ ol {indent 1}
+ pre {fill 0 family courier Tnowrap nowrap}
+ samp {family courier}
+ strong {weight bold}
+ tt {family courier}
+ u {Tunderline underline}
+ ul {indent 1}
+ var {style i}
+}
+
+# These are in common(?) use, but not defined in html2.0
+
+array set HMtag_map {
+ center {Tcenter center}
+ strike {Tstrike strike}
+ u {Tunderline underline}
+}
+
+# initial values
+
+set HMtag_map(hmstart) {
+ family times weight medium style r size 14
+ Tcenter "" Tlink "" Tnowrap "" Tunderline "" list list
+ fill 1 indent "" counter 0 adjust 0
+}
+
+# html tags that insert white space
+
+array set HMinsert_map {
+ blockquote "\n\n" /blockquote "\n"
+ br "\n"
+ dd "\n" /dd "\n"
+ dl "\n" /dl "\n"
+ dt "\n"
+ form "\n" /form "\n"
+ h1 "\n\n" /h1 "\n"
+ h2 "\n\n" /h2 "\n"
+ h3 "\n\n" /h3 "\n"
+ h4 "\n" /h4 "\n"
+ h5 "\n" /h5 "\n"
+ h6 "\n" /h6 "\n"
+ li "\n"
+ /dir "\n"
+ /ul "\n"
+ /ol "\n"
+ /menu "\n"
+ p "\n\n"
+ pre "\n" /pre "\n"
+}
+
+# tags that are list elements, that support "compact" rendering
+
+array set HMlist_elements {
+ ol 1 ul 1 menu 1 dl 1 dir 1
+}
+############################################
+# initialize the window and stack state
+
+proc HMinit_win {win} {
+ upvar #0 HM$win var
+
+ HMinit_state $win
+ $win tag configure underline -underline 1
+ $win tag configure center -justify center
+ $win tag configure nowrap -wrap none
+ $win tag configure rindent -rmargin $var(S_tab)c
+ $win tag configure strike -overstrike 1
+ $win tag configure mark -foreground red ;# list markers
+ $win tag configure list -spacing1 3p -spacing3 3p ;# regular lists
+ $win tag configure compact -spacing1 0p ;# compact lists
+ $win tag configure link -borderwidth 2 -foreground blue ;# hypertext links
+ HMset_indent $win $var(S_tab)
+ $win configure -wrap word
+
+ # configure the text insertion point
+ $win mark set $var(S_insert) 1.0
+
+ # for horizontal rules
+ $win tag configure thin -font [HMx_font times 2 medium r]
+ $win tag configure hr -relief sunken -borderwidth 2 -wrap none \
+ -tabs [winfo width $win]
+ bind $win <Configure> {
+ %W tag configure hr -tabs %w
+ %W tag configure last -spacing3 %h
+ }
+
+ # generic link enter callback
+
+ $win tag bind link <1> "HMlink_hit $win %x %y"
+}
+
+# set the indent spacing (in cm) for lists
+# TK uses a "weird" tabbing model that causes \t to insert a single
+# space if the current line position is past the tab setting
+
+proc HMset_indent {win cm} {
+ set tabs [expr $cm / 2.0]
+ $win configure -tabs ${tabs}c
+ foreach i {1 2 3 4 5 6 7 8 9} {
+ set tab [expr $i * $cm]
+ $win tag configure indent$i -lmargin1 ${tab}c -lmargin2 ${tab}c \
+ -tabs "[expr $tab + $tabs]c [expr $tab + 2*$tabs]c"
+ }
+}
+
+# reset the state of window - get ready for the next page
+# remove all but the font tags, and remove all form state
+
+proc HMreset_win {win} {
+ upvar #0 HM$win var
+ regsub -all { +[^L ][^ ]*} " [$win tag names] " {} tags
+ catch "$win tag delete $tags"
+ eval $win mark unset [$win mark names]
+ $win delete 0.0 end
+ $win tag configure hr -tabs [winfo width $win]
+
+ # configure the text insertion point
+ $win mark set $var(S_insert) 1.0
+
+ # remove form state. If any check/radio buttons still exists,
+ # their variables will be magically re-created, and never get
+ # cleaned up.
+ catch unset [info globals HM$win.form*]
+
+ HMinit_state $win
+ return HM$win
+}
+
+# initialize the window's state array
+# Parameters beginning with S_ are NOT reset
+# adjust_size: global font size adjuster
+# unknown: character to use for unknown entities
+# tab: tab stop (in cm)
+# stop: enabled to stop processing
+# update: how many tags between update calls
+# tags: number of tags processed so far
+# symbols: Symbols to use on un-ordered lists
+
+proc HMinit_state {win} {
+ upvar #0 HM$win var
+ array set tmp [array get var S_*]
+ catch {unset var}
+ array set var {
+ stop 0
+ tags 0
+ fill 0
+ list list
+ S_adjust_size 0
+ S_tab 1.0
+ S_unknown \xb7
+ S_update 10
+ S_symbols O*=+-o\xd7\xb0>:\xb7
+ S_insert Insert
+ }
+ array set var [array get tmp]
+}
+
+# alter the parameters of the text state
+# this allows an application to over-ride the default settings
+# it is called as: HMset_state -param value -param value ...
+
+array set HMparam_map {
+ -update S_update
+ -tab S_tab
+ -unknown S_unknown
+ -stop S_stop
+ -size S_adjust_size
+ -symbols S_symbols
+ -insert S_insert
+}
+
+proc HMset_state {win args} {
+ upvar #0 HM$win var
+ global HMparam_map
+ set bad 0
+ if {[catch {array set params $args}]} {return 0}
+ foreach i [array names params] {
+ incr bad [catch {set var($HMparam_map($i)) $params($i)}]
+ }
+ return [expr $bad == 0]
+}
+
+############################################
+# manage the display of html
+
+# HMrender gets called for every html tag
+# win: The name of the text widget to render into
+# tag: The html tag (in arbitrary case)
+# not: a "/" or the empty string
+# param: The un-interpreted parameter list
+# text: The plain text until the next html tag
+
+proc HMrender {win tag not param text} {
+ upvar #0 HM$win var
+ if {$var(stop)} return
+ global HMtag_map HMinsert_map HMlist_elements
+ set tag [string tolower $tag]
+ set text [HMmap_esc $text]
+
+ # manage compact rendering of lists
+ if {[info exists HMlist_elements($tag)]} {
+ set list "list [expr {[HMextract_param $param compact] ? "compact" : "list"}]"
+ } else {
+ set list ""
+ }
+
+ # Allow text to be diverted to a different window (for tables)
+ # this is not currently used
+ if {[info exists var(divert)]} {
+ set win $var(divert)
+ upvar #0 HM$win var
+ }
+
+ # adjust (push or pop) tag state
+ catch {HMstack $win $not "$HMtag_map($tag) $list"}
+
+ # insert white space (with current font)
+ # adding white space can get a bit tricky. This isn't quite right
+ set bad [catch {$win insert $var(S_insert) $HMinsert_map($not$tag) "space $var(font)"}]
+ if {!$bad && [lindex $var(fill) end]} {
+ set text [string trimleft $text]
+ }
+
+ # to fill or not to fill
+ if {[lindex $var(fill) end]} {
+ set text [HMzap_white $text]
+ }
+
+ # generic mark hook
+ catch {HMmark $not$tag $win $param text} err
+
+ # do any special tag processing
+ catch {HMtag_$not$tag $win $param text} msg
+
+
+ # add the text with proper tags
+
+ set tags [HMcurrent_tags $win]
+ $win insert $var(S_insert) $text $tags
+
+ # We need to do an update every so often to insure interactive response.
+ # This can cause us to re-enter the event loop, and cause recursive
+ # invocations of HMrender, so we need to be careful.
+ if {!([incr var(tags)] % $var(S_update))} {
+ update
+ }
+}
+
+# html tags requiring special processing
+# Procs of the form HMtag_<tag> or HMtag_</tag> get called just before
+# the text for this tag is displayed. These procs are called inside a
+# "catch" so it is OK to fail.
+# win: The name of the text widget to render into
+# param: The un-interpreted parameter list
+# text: A pass-by-reference name of the plain text until the next html tag
+# Tag commands may change this to affect what text will be inserted
+# next.
+
+# A pair of pseudo tags are added automatically as the 1st and last html
+# tags in the document. The default is <HMstart> and </HMstart>.
+# Append enough blank space at the end of the text widget while
+# rendering so HMgoto can place the target near the top of the page,
+# then remove the extra space when done rendering.
+
+proc HMtag_hmstart {win param text} {
+ upvar #0 HM$win var
+ $win mark gravity $var(S_insert) left
+ $win insert end "\n " last
+ $win mark gravity $var(S_insert) right
+}
+
+proc HMtag_/hmstart {win param text} {
+ $win delete last.first end
+}
+
+# put the document title in the window banner, and remove the title text
+# from the document
+
+proc HMtag_title {win param text} {
+ upvar $text data
+ wm title [winfo toplevel $win] $data
+ set data ""
+}
+
+proc HMtag_hr {win param text} {
+ upvar #0 HM$win var
+ $win insert $var(S_insert) "\n" space "\n" thin "\t" "thin hr" "\n" thin
+}
+
+# list element tags
+
+proc HMtag_ol {win param text} {
+ upvar #0 HM$win var
+ set var(count$var(level)) 0
+}
+
+proc HMtag_ul {win param text} {
+ upvar #0 HM$win var
+ catch {unset var(count$var(level))}
+}
+
+proc HMtag_menu {win param text} {
+ upvar #0 HM$win var
+ set var(menu) ->
+ set var(compact) 1
+}
+
+proc HMtag_/menu {win param text} {
+ upvar #0 HM$win var
+ catch {unset var(menu)}
+ catch {unset var(compact)}
+}
+
+proc HMtag_dt {win param text} {
+ upvar #0 HM$win var
+ upvar $text data
+ set level $var(level)
+ incr level -1
+ $win insert $var(S_insert) "$data" \
+ "hi [lindex $var(list) end] indent$level $var(font)"
+ set data {}
+}
+
+proc HMtag_li {win param text} {
+ upvar #0 HM$win var
+ set level $var(level)
+ incr level -1
+ set x [string index $var(S_symbols)+-+-+-+-" $level]
+ catch {set x [incr var(count$level)]}
+ catch {set x $var(menu)}
+ $win insert $var(S_insert) \t$x\t "mark [lindex $var(list) end] indent$level $var(font)"
+}
+
+# Manage hypertext "anchor" links. A link can be either a source (href)
+# a destination (name) or both. If its a source, register it via a callback,
+# and set its default behavior. If its a destination, check to see if we need
+# to go there now, as a result of a previous HMgoto request. If so, schedule
+# it to happen with the closing </a> tag, so we can highlight the text up to
+# the </a>.
+
+proc HMtag_a {win param text} {
+ upvar #0 HM$win var
+
+ # a source
+
+ if {[HMextract_param $param href]} {
+ set var(Tref) [list L:$href]
+ HMstack $win "" "Tlink link"
+ HMlink_setup $win $href
+ }
+
+ # a destination
+
+ if {[HMextract_param $param name]} {
+ set var(Tname) [list N:$name]
+ HMstack $win "" "Tanchor anchor"
+ $win mark set N:$name "$var(S_insert) - 1 chars"
+ $win mark gravity N:$name left
+ if {[info exists var(goto)] && $var(goto) == $name} {
+ unset var(goto)
+ set var(going) $name
+ }
+ }
+}
+
+# The application should call here with the fragment name
+# to cause the display to go to this spot.
+# If the target exists, go there (and do the callback),
+# otherwise schedule the goto to happen when we see the reference.
+
+proc HMgoto {win where {callback HMwent_to}} {
+ upvar #0 HM$win var
+ if {[regexp N:$where [$win mark names]]} {
+ $win see N:$where
+ update
+ eval $callback $win [list $where]
+ return 1
+ } else {
+ set var(goto) $where
+ return 0
+ }
+}
+
+# We actually got to the spot, so highlight it!
+# This should/could be replaced by the application
+# We'll flash it orange a couple of times.
+
+proc HMwent_to {win where {count 0} {color orange}} {
+ upvar #0 HM$win var
+ if {$count > 5} return
+ catch {$win tag configure N:$where -foreground $color}
+ update
+ after 200 [list HMwent_to $win $where [incr count] \
+ [expr {$color=="orange" ? "" : "orange"}]]
+}
+
+proc HMtag_/a {win param text} {
+ upvar #0 HM$win var
+ if {[info exists var(Tref)]} {
+ unset var(Tref)
+ HMstack $win / "Tlink link"
+ }
+
+ # goto this link, then invoke the call-back.
+
+ if {[info exists var(going)]} {
+ $win yview N:$var(going)
+ update
+ HMwent_to $win $var(going)
+ unset var(going)
+ }
+
+ if {[info exists var(Tname)]} {
+ unset var(Tname)
+ HMstack $win / "Tanchor anchor"
+ }
+}
+
+# Inline Images
+# This interface is subject to change
+# Most of the work is getting around a limitation of TK that prevents
+# setting the size of a label to a widthxheight in pixels
+#
+# Images have the following parameters:
+# align: top,middle,bottom
+# alt: alternate text
+# ismap: A clickable image map
+# src: The URL link
+# Netscape supports (and so do we)
+# width: A width hint (in pixels)
+# height: A height hint (in pixels)
+# border: The size of the window border
+
+proc HMtag_img {win param text} {
+ upvar #0 HM$win var
+
+ # get alignment
+ array set align_map {top top middle center bottom bottom}
+ set align bottom ;# The spec isn't clear what the default should be
+ HMextract_param $param align
+ catch {set align $align_map([string tolower $align])}
+
+ # get alternate text
+ set alt "<image>"
+ HMextract_param $param alt
+ set alt [HMmap_esc $alt]
+
+ # get the border width
+ set border 1
+ HMextract_param $param border
+
+ # see if we have an image size hint
+ # If so, make a frame the "hint" size to put the label in
+ # otherwise just make the label
+ set item $win.$var(tags)
+ # catch {destroy $item}
+ if {[HMextract_param $param width] && [HMextract_param $param height]} {
+ frame $item -width $width -height $height
+ pack propagate $item 0
+ set label $item.label
+ label $label
+ pack $label -expand 1 -fill both
+ } else {
+ set label $item
+ label $label
+ }
+
+ $label configure -relief ridge -fg orange -text $alt
+ catch {$label configure -bd $border}
+ $win window create $var(S_insert) -align $align -window $item -pady 2 -padx 2
+
+ # add in all the current tags (this is overkill)
+ set tags [HMcurrent_tags $win]
+ foreach tag $tags {
+ $win tag add $tag $item
+ }
+
+ # set imagemap callbacks
+ if {[HMextract_param $param ismap]} {
+ # regsub -all {[^L]*L:([^ ]*).*} $tags {\1} link
+ set link [lindex $tags [lsearch -glob $tags L:*]]
+ regsub L: $link {} link
+ global HMevents
+ regsub -all {%} $link {%%} link2
+ foreach i [array names HMevents] {
+ bind $label <$i> "catch \{%W configure $HMevents($i)\}"
+ }
+ bind $label <1> "+HMlink_callback $win $link2?%x,%y"
+ }
+
+ # now callback to the application
+ set src ""
+ HMextract_param $param src
+ HMset_image $win $label $src
+ return $label ;# used by the forms package for input_image types
+}
+
+# The app needs to supply one of these
+proc HMset_image {win handle src} {
+ HMgot_image $handle "can't get\n$src"
+}
+
+# When the image is available, the application should call back here.
+# If we have the image, put it in the label, otherwise display the error
+# message. If we don't get a callback, the "alt" text remains.
+# if we have a clickable image, arrange for a callback
+
+proc HMgot_image {win image_error} {
+ # if we're in a frame turn on geometry propogation
+ if {[winfo name $win] == "label"} {
+ pack propagate [winfo parent $win] 1
+ }
+ if {[catch {$win configure -image $image_error}]} {
+ $win configure -image {}
+ $win configure -text $image_error
+ }
+}
+
+# Sample hypertext link callback routine - should be replaced by app
+# This proc is called once for each <A> tag.
+# Applications can overwrite this procedure, as required, or
+# replace the HMevents array
+# win: The name of the text widget to render into
+# href: The HREF link for this <a> tag.
+
+array set HMevents {
+ Enter {-borderwidth 2 -relief raised }
+ Leave {-borderwidth 2 -relief flat }
+ 1 {-borderwidth 2 -relief sunken}
+ ButtonRelease-1 {-borderwidth 2 -relief raised}
+}
+
+# We need to escape any %'s in the href tag name so the bind command
+# doesn't try to substitute them.
+
+proc HMlink_setup {win href} {
+ global HMevents
+ regsub -all {%} $href {%%} href2
+ foreach i [array names HMevents] {
+ eval {$win tag bind L:$href <$i>} \
+ \{$win tag configure \{L:$href2\} $HMevents($i)\}
+ }
+}
+
+# generic link-hit callback
+# This gets called upon button hits on hypertext links
+# Applications are expected to supply ther own HMlink_callback routine
+# win: The name of the text widget to render into
+# x,y: The cursor position at the "click"
+
+proc HMlink_hit {win x y} {
+ set tags [$win tag names @$x,$y]
+ set link [lindex $tags [lsearch -glob $tags L:*]]
+ # regsub -all {[^L]*L:([^ ]*).*} $tags {\1} link
+ regsub L: $link {} link
+ HMlink_callback $win $link
+}
+
+# replace this!
+# win: The name of the text widget to render into
+# href: The HREF link for this <a> tag.
+
+proc HMlink_callback {win href} {
+ puts "Got hit on $win, link $href"
+}
+
+# extract a value from parameter list (this needs a re-do)
+# returns "1" if the keyword is found, "0" otherwise
+# param: A parameter list. It should alredy have been processed to
+# remove any entity references
+# key: The parameter name
+# val: The variable to put the value into (use key as default)
+
+proc HMextract_param {param key {val ""}} {
+
+ if {$val == ""} {
+ upvar $key result
+ } else {
+ upvar $val result
+ }
+ set ws " \n\r"
+
+ # look for name=value combinations. Either (') or (") are valid delimeters
+ if {
+ [regsub -nocase [format {.*%s[%s]*=[%s]*"([^"]*).*} $key $ws $ws] $param {\1} value] ||
+ [regsub -nocase [format {.*%s[%s]*=[%s]*'([^']*).*} $key $ws $ws] $param {\1} value] ||
+ [regsub -nocase [format {.*%s[%s]*=[%s]*([^%s]+).*} $key $ws $ws $ws] $param {\1} value] } {
+ set result $value
+ return 1
+ }
+
+ # now look for valueless names
+ # I should strip out name=value pairs, so we don't end up with "name"
+ # inside the "value" part of some other key word - some day
+
+ set bad \[^a-zA-Z\]+
+ if {[regexp -nocase "$bad$key$bad" -$param-]} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+# These next two routines manage the display state of the page.
+
+# Push or pop tags to/from stack.
+# Each orthogonal text property has its own stack, stored as a list.
+# The current (most recent) tag is the last item on the list.
+# Push is {} for pushing and {/} for popping
+
+proc HMstack {win push list} {
+ upvar #0 HM$win var
+ array set tags $list
+ if {$push == ""} {
+ foreach tag [array names tags] {
+ lappend var($tag) $tags($tag)
+ }
+ } else {
+ foreach tag [array names tags] {
+ # set cnt [regsub { *[^ ]+$} $var($tag) {} var($tag)]
+ set var($tag) [lreplace $var($tag) end end]
+ }
+ }
+}
+
+# extract set of current text tags
+# tags starting with T map directly to text tags, all others are
+# handled specially. There is an application callback, HMset_font
+# to allow the application to do font error handling
+
+proc HMcurrent_tags {win} {
+ upvar #0 HM$win var
+ set font font
+ foreach i {family size weight style} {
+ set $i [lindex $var($i) end]
+ append font :[set $i]
+ }
+ set xfont [HMx_font $family $size $weight $style $var(S_adjust_size)]
+ HMset_font $win $font $xfont
+ set indent [llength $var(indent)]
+ incr indent -1
+ lappend tags $font indent$indent
+ foreach tag [array names var T*] {
+ lappend tags [lindex $var($tag) end] ;# test
+ }
+ set var(font) $font
+ set var(xfont) [$win tag cget $font -font]
+ set var(level) $indent
+ return $tags
+}
+
+# allow the application to do do better font management
+# by overriding this procedure
+
+proc HMset_font {win tag font} {
+ catch {$win tag configure $tag -font $font} msg
+}
+
+# generate an X font name
+proc HMx_font {family size weight style {adjust_size 0}} {
+ catch {incr size $adjust_size}
+ return "-*-$family-$weight-$style-normal-*-*-${size}0-*-*-*-*-*-*"
+}
+
+# Optimize HMrender (hee hee)
+# This is experimental
+
+proc HMoptimize {} {
+ regsub -all "\n\[ \]*#\[^\n\]*" [info body HMrender] {} body
+ regsub -all ";\[ \]*#\[^\n]*" $body {} body
+ regsub -all "\n\n+" $body \n body
+ proc HMrender {win tag not param text} $body
+}
+############################################
+# Turn HTML into TCL commands
+# html A string containing an html document
+# cmd A command to run for each html tag found
+# start The name of the dummy html start/stop tags
+
+proc HMparse_html {html {cmd HMtest_parse} {start hmstart}} {
+ regsub -all \{ $html {\&ob;} html
+ regsub -all \} $html {\&cb;} html
+ set w " \t\r\n" ;# white space
+ proc HMcl x {return "\[$x\]"}
+ set exp <(/?)([HMcl ^$w>]+)[HMcl $w]*([HMcl ^>]*)>
+ set sub "\}\n$cmd {\\2} {\\1} {\\3} \{"
+ regsub -all $exp $html $sub html
+ eval "$cmd {$start} {} {} \{ $html \}"
+ eval "$cmd {$start} / {} {}"
+}
+
+proc HMtest_parse {command tag slash text_after_tag} {
+ puts "==> $command $tag $slash $text_after_tag"
+}
+
+# Convert multiple white space into a single space
+
+proc HMzap_white {data} {
+ regsub -all "\[ \t\r\n\]+" $data " " data
+ return $data
+}
+
+# find HTML escape characters of the form &xxx;
+
+proc HMmap_esc {text} {
+ if {![regexp & $text]} {return $text}
+ regsub -all {([][$\\])} $text {\\\1} new
+ regsub -all {&#([0-9][0-9]?[0-9]?);?} \
+ $new {[format %c [scan \1 %d tmp;set tmp]]} new
+ regsub -all {&([a-zA-Z]+);?} $new {[HMdo_map \1]} new
+ return [subst $new]
+}
+
+# convert an HTML escape sequence into character
+
+proc HMdo_map {text {unknown ?}} {
+ global HMesc_map
+ set result $unknown
+ catch {set result $HMesc_map($text)}
+ return $result
+}
+
+# table of escape characters (ISO latin-1 esc's are in a different table)
+
+array set HMesc_map {
+ lt < gt > amp & quot \" copy \xa9
+ reg \xae ob \x7b cb \x7d nbsp \xa0
+}
+#############################################################
+# ISO Latin-1 escape codes
+
+array set HMesc_map {
+ nbsp \xa0 iexcl \xa1 cent \xa2 pound \xa3 curren \xa4
+ yen \xa5 brvbar \xa6 sect \xa7 uml \xa8 copy \xa9
+ ordf \xaa laquo \xab not \xac shy \xad reg \xae
+ hibar \xaf deg \xb0 plusmn \xb1 sup2 \xb2 sup3 \xb3
+ acute \xb4 micro \xb5 para \xb6 middot \xb7 cedil \xb8
+ sup1 \xb9 ordm \xba raquo \xbb frac14 \xbc frac12 \xbd
+ frac34 \xbe iquest \xbf Agrave \xc0 Aacute \xc1 Acirc \xc2
+ Atilde \xc3 Auml \xc4 Aring \xc5 AElig \xc6 Ccedil \xc7
+ Egrave \xc8 Eacute \xc9 Ecirc \xca Euml \xcb Igrave \xcc
+ Iacute \xcd Icirc \xce Iuml \xcf ETH \xd0 Ntilde \xd1
+ Ograve \xd2 Oacute \xd3 Ocirc \xd4 Otilde \xd5 Ouml \xd6
+ times \xd7 Oslash \xd8 Ugrave \xd9 Uacute \xda Ucirc \xdb
+ Uuml \xdc Yacute \xdd THORN \xde szlig \xdf agrave \xe0
+ aacute \xe1 acirc \xe2 atilde \xe3 auml \xe4 aring \xe5
+ aelig \xe6 ccedil \xe7 egrave \xe8 eacute \xe9 ecirc \xea
+ euml \xeb igrave \xec iacute \xed icirc \xee iuml \xef
+ eth \xf0 ntilde \xf1 ograve \xf2 oacute \xf3 ocirc \xf4
+ otilde \xf5 ouml \xf6 divide \xf7 oslash \xf8 ugrave \xf9
+ uacute \xfa ucirc \xfb uuml \xfc yacute \xfd thorn \xfe
+ yuml \xff
+}
+
+##########################################################
+# html forms management commands
+
+# As each form element is located, it is created and rendered. Additional
+# state is stored in a form specific global variable to be processed at
+# the end of the form, including the "reset" and "submit" options.
+# Remember, there can be multiple forms existing on multiple pages. When
+# HTML tables are added, a single form could be spread out over multiple
+# text widgets, which makes it impractical to hang the form state off the
+# HM$win structure. We don't need to check for the existance of required
+# parameters, we just "fail" and get caught in HMrender
+
+# This causes line breaks to be preserved in the inital values
+# of text areas
+array set HMtag_map {
+ textarea {fill 0}
+}
+
+##########################################################
+# html isindex tag. Although not strictly forms, they're close enough
+# to be in this file
+
+# is-index forms
+# make a frame with a label, entry, and submit button
+
+proc HMtag_isindex {win param text} {
+ upvar #0 HM$win var
+
+ set item $win.$var(tags)
+ if {[winfo exists $item]} {
+ destroy $item
+ }
+ frame $item -relief ridge -bd 3
+ set prompt "Enter search keywords here"
+ HMextract_param $param prompt
+ label $item.label -text [HMmap_esc $prompt] -font $var(xfont)
+ entry $item.entry
+ bind $item.entry <Return> "$item.submit invoke"
+ button $item.submit -text search -font $var(xfont) -command \
+ [format {HMsubmit_index %s {%s} [HMmap_reply [%s get]]} \
+ $win $param $item.entry]
+ pack $item.label -side top
+ pack $item.entry $item.submit -side left
+
+ # insert window into text widget
+
+ $win insert $var(S_insert) \n isindex
+ HMwin_install $win $item
+ $win insert $var(S_insert) \n isindex
+ bind $item <Visibility> {focus %W.entry}
+}
+
+# This is called when the isindex form is submitted.
+# The default version calls HMlink_callback. Isindex tags should either
+# be deprecated, or fully supported (e.g. they need an href parameter)
+
+proc HMsubmit_index {win param text} {
+ HMlink_callback $win ?$text
+}
+
+# initialize form state. All of the state for this form is kept
+# in a global array whose name is stored in the form_id field of
+# the main window array.
+# Parameters: ACTION, METHOD, ENCTYPE
+
+proc HMtag_form {win param text} {
+ upvar #0 HM$win var
+
+ # create a global array for the form
+ set id HM$win.form$var(tags)
+ upvar #0 $id form
+
+ # missing /form tag, simulate it
+ if {[info exists var(form_id)]} {
+ puts "Missing end-form tag !!!! $var(form_id)"
+ HMtag_/form $win {} {}
+ }
+ catch {unset form}
+ set var(form_id) $id
+
+ set form(param) $param ;# form initial parameter list
+ set form(reset) "" ;# command to reset the form
+ set form(reset_button) "" ;# list of all reset buttons
+ set form(submit) "" ;# command to submit the form
+ set form(submit_button) "" ;# list of all submit buttons
+}
+
+# Where we're done try to get all of the state into the widgets so
+# we can free up the form structure here. Unfortunately, we can't!
+
+proc HMtag_/form {win param text} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+
+ # make submit button entries for all radio buttons
+ foreach name [array names form radio_*] {
+ regsub radio_ $name {} name
+ lappend form(submit) [list $name \$form(radio_$name)]
+ }
+
+ # process the reset button(s)
+
+ foreach item $form(reset_button) {
+ $item configure -command $form(reset)
+ }
+
+ # no submit button - add one
+ if {$form(submit_button) == ""} {
+ HMinput_submit $win {}
+ }
+
+ # process the "submit" command(s)
+ # each submit button could have its own name,value pair
+
+ foreach item $form(submit_button) {
+ set submit $form(submit)
+ catch {lappend submit $form(submit_$item)}
+ $item configure -command \
+ [list HMsubmit_button $win $var(form_id) $form(param) \
+ $submit]
+ }
+
+ # unset all unused fields here
+ unset form(reset) form(submit) form(reset_button) form(submit_button)
+ unset var(form_id)
+}
+
+###################################################################
+# handle form input items
+# each item type is handled in a separate procedure
+# Each "type" procedure needs to:
+# - create the window
+# - initialize it
+# - add the "submit" and "reset" commands onto the proper Q's
+# "submit" is subst'd
+# "reset" is eval'd
+
+proc HMtag_input {win param text} {
+ upvar #0 HM$win var
+
+ set type text ;# the default
+ HMextract_param $param type
+ set type [string tolower $type]
+ if {[catch {HMinput_$type $win $param} err]} {
+ puts stderr $err
+ }
+}
+
+# input type=text
+# parameters NAME (reqd), MAXLENGTH, SIZE, VALUE
+
+proc HMinput_text {win param {show {}}} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+
+ # make the entry
+ HMextract_param $param name ;# required
+ set item $win.input_text,$var(tags)
+ set size 20; HMextract_param $param size
+ set maxlength 0; HMextract_param $param maxlength
+ entry $item -width $size -show $show
+
+ # set the initial value
+ set value ""; HMextract_param $param value
+ $item insert 0 $value
+
+ # insert the entry
+ HMwin_install $win $item
+
+ # set the "reset" and "submit" commands
+ append form(reset) ";$item delete 0 end;$item insert 0 [list $value]"
+ lappend form(submit) [list $name "\[$item get]"]
+
+ # handle the maximum length (broken - no way to cleanup bindtags state)
+ if {$maxlength} {
+ bindtags $item "[bindtags $item] max$maxlength"
+ bind max$maxlength <KeyPress> "%W delete $maxlength end"
+ }
+}
+
+# password fields - same as text, only don't show data
+# parameters NAME (reqd), MAXLENGTH, SIZE, VALUE
+
+proc HMinput_password {win param} {
+ HMinput_text $win $param *
+}
+
+# checkbuttons are missing a "get" option, so we must use a global
+# variable to store the value.
+# Parameters NAME, VALUE, (reqd), CHECKED
+
+proc HMinput_checkbox {win param} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+
+ HMextract_param $param name
+ HMextract_param $param value
+
+ # Set the global variable, don't use the "form" alias as it is not
+ # defined in the global scope of the button
+ set variable $var(form_id)(check_$var(tags))
+ set item $win.input_checkbutton,$var(tags)
+ checkbutton $item -variable $variable -off {} -on $value -text " "
+ if {[HMextract_param $param checked]} {
+ $item select
+ append form(reset) ";$item select"
+ } else {
+ append form(reset) ";$item deselect"
+ }
+
+ HMwin_install $win $item
+ lappend form(submit) [list $name \$form(check_$var(tags))]
+}
+
+# radio buttons. These are like check buttons, but only one can be selected
+
+proc HMinput_radio {win param} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+
+ HMextract_param $param name
+ HMextract_param $param value
+
+ set first [expr ![info exists form(radio_$name)]]
+ set variable $var(form_id)(radio_$name)
+ set variable $var(form_id)(radio_$name)
+ set item $win.input_radiobutton,$var(tags)
+ radiobutton $item -variable $variable -value $value -text " "
+
+ HMwin_install $win $item
+
+ if {$first || [HMextract_param $param checked]} {
+ $item select
+ append form(reset) ";$item select"
+ } else {
+ append form(reset) ";$item deselect"
+ }
+
+ # do the "submit" actions in /form so we only end up with 1 per button grouping
+ # contributing to the submission
+}
+
+# hidden fields, just append to the "submit" data
+# params: NAME, VALUE (reqd)
+
+proc HMinput_hidden {win param} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+ HMextract_param $param name
+ HMextract_param $param value
+ lappend form(submit) [list $name $value]
+}
+
+# handle input images. The spec isn't very clear on these, so I'm not
+# sure its quite right
+# Use std image tag, only set up our own callbacks
+# (e.g. make sure ismap isn't set)
+# params: NAME, SRC (reqd) ALIGN
+
+proc HMinput_image {win param} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+ HMextract_param $param name
+ set name ;# barf if no name is specified
+ set item [HMtag_img $win $param {}]
+ $item configure -relief raised -bd 2 -bg blue
+
+ # make a dummy "submit" button, and invoke it to send the form.
+ # We have to get the %x,%y in the value somehow, so calculate it during
+ # binding, and save it in the form array for later processing
+
+ set submit $win.dummy_submit,$var(tags)
+ if {[winfo exists $submit]} {
+ destroy $submit
+ }
+ button $submit -takefocus 0;# this never gets mapped!
+ lappend form(submit_button) $submit
+ set form(submit_$submit) [list $name $name.\$form(X).\$form(Y)]
+
+ $item configure -takefocus 1
+ bind $item <FocusIn> "catch \{$win see $item\}"
+ bind $item <1> "$item configure -relief sunken"
+ bind $item <Return> "
+ set $var(form_id)(X) 0
+ set $var(form_id)(Y) 0
+ $submit invoke
+ "
+ bind $item <ButtonRelease-1> "
+ set $var(form_id)(X) %x
+ set $var(form_id)(Y) %y
+ $item configure -relief raised
+ $submit invoke
+ "
+}
+
+# Set up the reset button. Wait for the /form to attach
+# the -command option. There could be more that 1 reset button
+# params VALUE
+
+proc HMinput_reset {win param} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+
+ set value reset
+ HMextract_param $param value
+
+ set item $win.input_reset,$var(tags)
+ button $item -text [HMmap_esc $value]
+ HMwin_install $win $item
+ lappend form(reset_button) $item
+}
+
+# Set up the submit button. Wait for the /form to attach
+# the -command option. There could be more that 1 submit button
+# params: NAME, VALUE
+
+proc HMinput_submit {win param} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+
+ HMextract_param $param name
+ set value submit
+ HMextract_param $param value
+ set item $win.input_submit,$var(tags)
+ button $item -text [HMmap_esc $value] -fg blue
+ HMwin_install $win $item
+ lappend form(submit_button) $item
+ # need to tie the "name=value" to this button
+ # save the pair and do it when we finish the submit button
+ catch {set form(submit_$item) [list $name $value]}
+}
+
+#########################################################################
+# selection items
+# They all go into a list box. We don't what to do with the listbox until
+# we know how many items end up in it. Gather up the data for the "options"
+# and finish up in the /select tag
+# params: NAME (reqd), MULTIPLE, SIZE
+
+proc HMtag_select {win param text} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+
+ HMextract_param $param name
+ set size 5; HMextract_param $param size
+ set form(select_size) $size
+ set form(select_name) $name
+ set form(select_values) "" ;# list of values to submit
+ if {[HMextract_param $param multiple]} {
+ set mode multiple
+ } else {
+ set mode single
+ }
+ set item $win.select,$var(tags)
+ frame $item
+ set form(select_frame) $item
+ listbox $item.list -selectmode $mode -width 0 -exportselection 0
+ HMwin_install $win $item
+}
+
+# select options
+# The values returned in the query may be different from those
+# displayed in the listbox, so we need to keep a separate list of
+# query values.
+# form(select_default) - contains the default query value
+# form(select_frame) - name of the listbox's containing frame
+# form(select_values) - list of query values
+# params: VALUE, SELECTED
+
+proc HMtag_option {win param text} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+ upvar $text data
+ set frame $form(select_frame)
+
+ # set default option (or options)
+ if {[HMextract_param $param selected]} {
+ lappend form(select_default) [$form(select_frame).list size]
+ }
+ set value [string trimright $data " \n"]
+ $frame.list insert end $value
+ HMextract_param $param value
+ lappend form(select_values) $value
+ set data ""
+}
+
+# do most of the work here!
+# if SIZE>1, make the listbox. Otherwise make a "drop-down"
+# listbox with a label in it
+# If the # of items > size, add a scroll bar
+# This should probably be broken up into callbacks to make it
+# easier to override the "look".
+
+proc HMtag_/select {win param text} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+ set frame $form(select_frame)
+ set size $form(select_size)
+ set items [$frame.list size]
+
+ # set the defaults and reset button
+ append form(reset) ";$frame.list selection clear 0 $items"
+ if {[info exists form(select_default)]} {
+ foreach i $form(select_default) {
+ $frame.list selection set $i
+ append form(reset) ";$frame.list selection set $i"
+ }
+ } else {
+ $frame.list selection set 0
+ append form(reset) ";$frame.list selection set 0"
+ }
+
+ # set up the submit button. This is the general case. For single
+ # selections we could be smarter
+
+ for {set i 0} {$i < $size} {incr i} {
+ set value [format {[expr {[%s selection includes %s] ? {%s} : {}}]} \
+ $frame.list $i [lindex $form(select_values) $i]]
+ lappend form(submit) [list $form(select_name) $value]
+ }
+
+ # show the listbox - no scroll bar
+
+ if {$size > 1 && $items <= $size} {
+ $frame.list configure -height $items
+ pack $frame.list
+
+ # Listbox with scrollbar
+
+ } elseif {$size > 1} {
+ scrollbar $frame.scroll -command "$frame.list yview" \
+ -orient v -takefocus 0
+ $frame.list configure -height $size \
+ -yscrollcommand "$frame.scroll set"
+ pack $frame.list $frame.scroll -side right -fill y
+
+ # This is a joke!
+
+ } else {
+ scrollbar $frame.scroll -command "$frame.list yview" \
+ -orient h -takefocus 0
+ $frame.list configure -height 1 \
+ -yscrollcommand "$frame.scroll set"
+ pack $frame.list $frame.scroll -side top -fill x
+ }
+
+ # cleanup
+
+ foreach i [array names form select_*] {
+ unset form($i)
+ }
+}
+
+# do a text area (multi-line text)
+# params: COLS, NAME, ROWS (all reqd, but default rows and cols anyway)
+
+proc HMtag_textarea {win param text} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+ upvar $text data
+
+ set rows 5; HMextract_param $param rows
+ set cols 30; HMextract_param $param cols
+ HMextract_param $param name
+ set item $win.textarea,$var(tags)
+ frame $item
+ text $item.text -width $cols -height $rows -wrap none \
+ -yscrollcommand "$item.scroll set" -padx 3 -pady 3
+ scrollbar $item.scroll -command "$item.text yview" -orient v
+ $item.text insert 1.0 $data
+ HMwin_install $win $item
+ pack $item.text $item.scroll -side right -fill y
+ lappend form(submit) [list $name "\[$item.text get 0.0 end]"]
+ append form(reset) ";$item.text delete 1.0 end; \
+ $item.text insert 1.0 [list $data]"
+ set data ""
+}
+
+# procedure to install windows into the text widget
+# - win: name of the text widget
+# - item: name of widget to install
+
+proc HMwin_install {win item} {
+ upvar #0 HM$win var
+ $win window create $var(S_insert) -window $item -align bottom
+ $win tag add indent$var(level) $item
+ set focus [expr {[winfo class $item] != "Frame"}]
+ $item configure -takefocus $focus
+ bind $item <FocusIn> "$win see $item"
+}
+
+#####################################################################
+# Assemble and submit the query
+# each list element in "stuff" is a name/value pair
+# - The names are the NAME parameters of the various fields
+# - The values get run through "subst" to extract the values
+# - We do the user callback with the list of name value pairs
+
+proc HMsubmit_button {win form_id param stuff} {
+ upvar #0 HM$win var
+ upvar #0 $form_id form
+ set query ""
+ foreach pair $stuff {
+ set value [subst [lindex $pair 1]]
+ if {$value != ""} {
+ set item [lindex $pair 0]
+ lappend query $item $value
+ }
+ }
+ # this is the user callback.
+ HMsubmit_form $win $param $query
+}
+
+# sample user callback for form submission
+# should be replaced by the application
+# Sample version generates a string suitable for http
+
+proc HMsubmit_form {win param query} {
+ set result ""
+ set sep ""
+ foreach i $query {
+ append result $sep [HMmap_reply $i]
+ if {$sep != "="} {set sep =} {set sep &}
+ }
+ puts $result
+}
+
+# do x-www-urlencoded character mapping
+# The spec says: "non-alphanumeric characters are replaced by '%HH'"
+
+set HMalphanumeric a-zA-Z0-9 ;# definition of alphanumeric character class
+for {set i 1} {$i <= 256} {incr i} {
+ set c [format %c $i]
+ if {![string match \[$HMalphanumeric\] $c]} {
+ set HMform_map($c) %[format %.2x $i]
+ }
+}
+
+# These are handled specially
+array set HMform_map {
+ " " + \n %0d%0a
+}
+
+# 1 leave alphanumerics characters alone
+# 2 Convert every other character to an array lookup
+# 3 Escape constructs that are "special" to the tcl parser
+# 4 "subst" the result, doing all the array substitutions
+
+proc HMmap_reply {string} {
+ global HMform_map HMalphanumeric
+ regsub -all \[^$HMalphanumeric\] $string {$HMform_map(&)} string
+ regsub -all \n $string {\\n} string
+ regsub -all \t $string {\\t} string
+ regsub -all {[][{})\\]\)} $string {\\&} string
+ return [subst $string]
+}
+
+# convert a x-www-urlencoded string int a a list of name/value pairs
+
+# 1 convert a=b&c=d... to {a} {b} {c} {d}...
+# 2, convert + to " "
+# 3, convert %xx to char equiv
+
+proc HMcgiDecode {data} {
+ set data [split $data "&="]
+ foreach i $data {
+ lappend result [cgiMap $i]
+ }
+ return $result
+}
+
+proc HMcgiMap {data} {
+ regsub -all {\+} $data " " data
+
+ if {[regexp % $data]} {
+ regsub -all {([][$\\])} $data {\\\1} data
+ regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data
+ return [subst $data]
+ } else {
+ return $data
+ }
+}
+
+# There is a bug in the tcl library focus routines that prevents focus
+# from every reaching an un-viewable window. Use our *own*
+# version of the library routine, until the bug is fixed, make sure we
+# over-ride the library version, and not the otherway around
+
+auto_load tkFocusOK
+proc tkFocusOK w {
+ set code [catch {$w cget -takefocus} value]
+ if {($code == 0) && ($value != "")} {
+ if {$value == 0} {
+ return 0
+ } elseif {$value == 1} {
+ return 1
+ } else {
+ set value [uplevel #0 $value $w]
+ if {$value != ""} {
+ return $value
+ }
+ }
+ }
+ set code [catch {$w cget -state} value]
+ if {($code == 0) && ($value == "disabled")} {
+ return 0
+ }
+ regexp Key|Focus "[bind $w] [bind [winfo class $w]]"
+}
Deleted: grass/trunk/lib/form/html_library_grass.tcl
===================================================================
--- grass/trunk/lib/form/html_library_grass.tcl 2009-01-04 14:37:12 UTC (rev 35193)
+++ grass/trunk/lib/form/html_library_grass.tcl 2009-01-04 15:47:39 UTC (rev 35199)
@@ -1,1418 +0,0 @@
-# Simple HTML display library by Stephen Uhler (stephen.uhler at sun.com)
-# Copyright (c) 1995 by Sun Microsystems
-# Version 0.3 Fri Sep 1 10:47:17 PDT 1995
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-#
-# To use this package, create a text widget (say, .text)
-# and set a variable full of html, (say $html), and issue:
-# HMinit_win .text
-# HMparse_html $html "HMrender .text"
-# You also need to supply the routine:
-# proc HMlink_callback {win href} { ...}
-# win: The name of the text widget
-# href The name of the link
-# which will be called anytime the user "clicks" on a link.
-# The supplied version just prints the link to stdout.
-# In addition, if you wish to use embedded images, you will need to write
-# proc HMset_image {handle src}
-# handle an arbitrary handle (not really)
-# src The name of the image
-# Which calls
-# HMgot_image $handle $image
-# with the TK image.
-#
-# To return a "used" text widget to its initialized state, call:
-# HMreset_win .text
-# See "sample.tcl" for sample usage
-##################################################################
-############################################
-# mapping of html tags to text tag properties
-# properties beginning with "T" map directly to text tags
-
-# These are Defined in HTML 2.0
-
-array set HMtag_map {
- b {weight bold}
- blockquote {style i indent 1 Trindent rindent}
- bq {style i indent 1 Trindent rindent}
- cite {style i}
- code {family courier}
- dfn {style i}
- dir {indent 1}
- dl {indent 1}
- em {style i}
- h1 {size 24 weight bold}
- h2 {size 22}
- h3 {size 20}
- h4 {size 18}
- h5 {size 16}
- h6 {style i}
- i {style i}
- kbd {family courier weight bold}
- menu {indent 1}
- ol {indent 1}
- pre {fill 0 family courier Tnowrap nowrap}
- samp {family courier}
- strong {weight bold}
- tt {family courier}
- u {Tunderline underline}
- ul {indent 1}
- var {style i}
-}
-
-# These are in common(?) use, but not defined in html2.0
-
-array set HMtag_map {
- center {Tcenter center}
- strike {Tstrike strike}
- u {Tunderline underline}
-}
-
-# initial values
-
-set HMtag_map(hmstart) {
- family times weight medium style r size 14
- Tcenter "" Tlink "" Tnowrap "" Tunderline "" list list
- fill 1 indent "" counter 0 adjust 0
-}
-
-# html tags that insert white space
-
-array set HMinsert_map {
- blockquote "\n\n" /blockquote "\n"
- br "\n"
- dd "\n" /dd "\n"
- dl "\n" /dl "\n"
- dt "\n"
- form "\n" /form "\n"
- h1 "\n\n" /h1 "\n"
- h2 "\n\n" /h2 "\n"
- h3 "\n\n" /h3 "\n"
- h4 "\n" /h4 "\n"
- h5 "\n" /h5 "\n"
- h6 "\n" /h6 "\n"
- li "\n"
- /dir "\n"
- /ul "\n"
- /ol "\n"
- /menu "\n"
- p "\n\n"
- pre "\n" /pre "\n"
-}
-
-# tags that are list elements, that support "compact" rendering
-
-array set HMlist_elements {
- ol 1 ul 1 menu 1 dl 1 dir 1
-}
-############################################
-# initialize the window and stack state
-
-proc HMinit_win {win} {
- upvar #0 HM$win var
-
- HMinit_state $win
- $win tag configure underline -underline 1
- $win tag configure center -justify center
- $win tag configure nowrap -wrap none
- $win tag configure rindent -rmargin $var(S_tab)c
- $win tag configure strike -overstrike 1
- $win tag configure mark -foreground red ;# list markers
- $win tag configure list -spacing1 3p -spacing3 3p ;# regular lists
- $win tag configure compact -spacing1 0p ;# compact lists
- $win tag configure link -borderwidth 2 -foreground blue ;# hypertext links
- HMset_indent $win $var(S_tab)
- $win configure -wrap word
-
- # configure the text insertion point
- $win mark set $var(S_insert) 1.0
-
- # for horizontal rules
- $win tag configure thin -font [HMx_font times 2 medium r]
- $win tag configure hr -relief sunken -borderwidth 2 -wrap none \
- -tabs [winfo width $win]
- bind $win <Configure> {
- %W tag configure hr -tabs %w
- %W tag configure last -spacing3 %h
- }
-
- # generic link enter callback
-
- $win tag bind link <1> "HMlink_hit $win %x %y"
-}
-
-# set the indent spacing (in cm) for lists
-# TK uses a "weird" tabbing model that causes \t to insert a single
-# space if the current line position is past the tab setting
-
-proc HMset_indent {win cm} {
- set tabs [expr $cm / 2.0]
- $win configure -tabs ${tabs}c
- foreach i {1 2 3 4 5 6 7 8 9} {
- set tab [expr $i * $cm]
- $win tag configure indent$i -lmargin1 ${tab}c -lmargin2 ${tab}c \
- -tabs "[expr $tab + $tabs]c [expr $tab + 2*$tabs]c"
- }
-}
-
-# reset the state of window - get ready for the next page
-# remove all but the font tags, and remove all form state
-
-proc HMreset_win {win} {
- upvar #0 HM$win var
- regsub -all { +[^L ][^ ]*} " [$win tag names] " {} tags
- catch "$win tag delete $tags"
- eval $win mark unset [$win mark names]
- $win delete 0.0 end
- $win tag configure hr -tabs [winfo width $win]
-
- # configure the text insertion point
- $win mark set $var(S_insert) 1.0
-
- # remove form state. If any check/radio buttons still exists,
- # their variables will be magically re-created, and never get
- # cleaned up.
- catch unset [info globals HM$win.form*]
-
- HMinit_state $win
- return HM$win
-}
-
-# initialize the window's state array
-# Parameters beginning with S_ are NOT reset
-# adjust_size: global font size adjuster
-# unknown: character to use for unknown entities
-# tab: tab stop (in cm)
-# stop: enabled to stop processing
-# update: how many tags between update calls
-# tags: number of tags processed so far
-# symbols: Symbols to use on un-ordered lists
-
-proc HMinit_state {win} {
- upvar #0 HM$win var
- array set tmp [array get var S_*]
- catch {unset var}
- array set var {
- stop 0
- tags 0
- fill 0
- list list
- S_adjust_size 0
- S_tab 1.0
- S_unknown \xb7
- S_update 10
- S_symbols O*=+-o\xd7\xb0>:\xb7
- S_insert Insert
- }
- array set var [array get tmp]
-}
-
-# alter the parameters of the text state
-# this allows an application to over-ride the default settings
-# it is called as: HMset_state -param value -param value ...
-
-array set HMparam_map {
- -update S_update
- -tab S_tab
- -unknown S_unknown
- -stop S_stop
- -size S_adjust_size
- -symbols S_symbols
- -insert S_insert
-}
-
-proc HMset_state {win args} {
- upvar #0 HM$win var
- global HMparam_map
- set bad 0
- if {[catch {array set params $args}]} {return 0}
- foreach i [array names params] {
- incr bad [catch {set var($HMparam_map($i)) $params($i)}]
- }
- return [expr $bad == 0]
-}
-
-############################################
-# manage the display of html
-
-# HMrender gets called for every html tag
-# win: The name of the text widget to render into
-# tag: The html tag (in arbitrary case)
-# not: a "/" or the empty string
-# param: The un-interpreted parameter list
-# text: The plain text until the next html tag
-
-proc HMrender {win tag not param text} {
- upvar #0 HM$win var
- if {$var(stop)} return
- global HMtag_map HMinsert_map HMlist_elements
- set tag [string tolower $tag]
- set text [HMmap_esc $text]
-
- # manage compact rendering of lists
- if {[info exists HMlist_elements($tag)]} {
- set list "list [expr {[HMextract_param $param compact] ? "compact" : "list"}]"
- } else {
- set list ""
- }
-
- # Allow text to be diverted to a different window (for tables)
- # this is not currently used
- if {[info exists var(divert)]} {
- set win $var(divert)
- upvar #0 HM$win var
- }
-
- # adjust (push or pop) tag state
- catch {HMstack $win $not "$HMtag_map($tag) $list"}
-
- # insert white space (with current font)
- # adding white space can get a bit tricky. This isn't quite right
- set bad [catch {$win insert $var(S_insert) $HMinsert_map($not$tag) "space $var(font)"}]
- if {!$bad && [lindex $var(fill) end]} {
- set text [string trimleft $text]
- }
-
- # to fill or not to fill
- if {[lindex $var(fill) end]} {
- set text [HMzap_white $text]
- }
-
- # generic mark hook
- catch {HMmark $not$tag $win $param text} err
-
- # do any special tag processing
- catch {HMtag_$not$tag $win $param text} msg
-
-
- # add the text with proper tags
-
- set tags [HMcurrent_tags $win]
- $win insert $var(S_insert) $text $tags
-
- # We need to do an update every so often to insure interactive response.
- # This can cause us to re-enter the event loop, and cause recursive
- # invocations of HMrender, so we need to be careful.
- if {!([incr var(tags)] % $var(S_update))} {
- update
- }
-}
-
-# html tags requiring special processing
-# Procs of the form HMtag_<tag> or HMtag_</tag> get called just before
-# the text for this tag is displayed. These procs are called inside a
-# "catch" so it is OK to fail.
-# win: The name of the text widget to render into
-# param: The un-interpreted parameter list
-# text: A pass-by-reference name of the plain text until the next html tag
-# Tag commands may change this to affect what text will be inserted
-# next.
-
-# A pair of pseudo tags are added automatically as the 1st and last html
-# tags in the document. The default is <HMstart> and </HMstart>.
-# Append enough blank space at the end of the text widget while
-# rendering so HMgoto can place the target near the top of the page,
-# then remove the extra space when done rendering.
-
-proc HMtag_hmstart {win param text} {
- upvar #0 HM$win var
- $win mark gravity $var(S_insert) left
- $win insert end "\n " last
- $win mark gravity $var(S_insert) right
-}
-
-proc HMtag_/hmstart {win param text} {
- $win delete last.first end
-}
-
-# put the document title in the window banner, and remove the title text
-# from the document
-
-proc HMtag_title {win param text} {
- upvar $text data
- wm title [winfo toplevel $win] $data
- set data ""
-}
-
-proc HMtag_hr {win param text} {
- upvar #0 HM$win var
- $win insert $var(S_insert) "\n" space "\n" thin "\t" "thin hr" "\n" thin
-}
-
-# list element tags
-
-proc HMtag_ol {win param text} {
- upvar #0 HM$win var
- set var(count$var(level)) 0
-}
-
-proc HMtag_ul {win param text} {
- upvar #0 HM$win var
- catch {unset var(count$var(level))}
-}
-
-proc HMtag_menu {win param text} {
- upvar #0 HM$win var
- set var(menu) ->
- set var(compact) 1
-}
-
-proc HMtag_/menu {win param text} {
- upvar #0 HM$win var
- catch {unset var(menu)}
- catch {unset var(compact)}
-}
-
-proc HMtag_dt {win param text} {
- upvar #0 HM$win var
- upvar $text data
- set level $var(level)
- incr level -1
- $win insert $var(S_insert) "$data" \
- "hi [lindex $var(list) end] indent$level $var(font)"
- set data {}
-}
-
-proc HMtag_li {win param text} {
- upvar #0 HM$win var
- set level $var(level)
- incr level -1
- set x [string index $var(S_symbols)+-+-+-+-" $level]
- catch {set x [incr var(count$level)]}
- catch {set x $var(menu)}
- $win insert $var(S_insert) \t$x\t "mark [lindex $var(list) end] indent$level $var(font)"
-}
-
-# Manage hypertext "anchor" links. A link can be either a source (href)
-# a destination (name) or both. If its a source, register it via a callback,
-# and set its default behavior. If its a destination, check to see if we need
-# to go there now, as a result of a previous HMgoto request. If so, schedule
-# it to happen with the closing </a> tag, so we can highlight the text up to
-# the </a>.
-
-proc HMtag_a {win param text} {
- upvar #0 HM$win var
-
- # a source
-
- if {[HMextract_param $param href]} {
- set var(Tref) [list L:$href]
- HMstack $win "" "Tlink link"
- HMlink_setup $win $href
- }
-
- # a destination
-
- if {[HMextract_param $param name]} {
- set var(Tname) [list N:$name]
- HMstack $win "" "Tanchor anchor"
- $win mark set N:$name "$var(S_insert) - 1 chars"
- $win mark gravity N:$name left
- if {[info exists var(goto)] && $var(goto) == $name} {
- unset var(goto)
- set var(going) $name
- }
- }
-}
-
-# The application should call here with the fragment name
-# to cause the display to go to this spot.
-# If the target exists, go there (and do the callback),
-# otherwise schedule the goto to happen when we see the reference.
-
-proc HMgoto {win where {callback HMwent_to}} {
- upvar #0 HM$win var
- if {[regexp N:$where [$win mark names]]} {
- $win see N:$where
- update
- eval $callback $win [list $where]
- return 1
- } else {
- set var(goto) $where
- return 0
- }
-}
-
-# We actually got to the spot, so highlight it!
-# This should/could be replaced by the application
-# We'll flash it orange a couple of times.
-
-proc HMwent_to {win where {count 0} {color orange}} {
- upvar #0 HM$win var
- if {$count > 5} return
- catch {$win tag configure N:$where -foreground $color}
- update
- after 200 [list HMwent_to $win $where [incr count] \
- [expr {$color=="orange" ? "" : "orange"}]]
-}
-
-proc HMtag_/a {win param text} {
- upvar #0 HM$win var
- if {[info exists var(Tref)]} {
- unset var(Tref)
- HMstack $win / "Tlink link"
- }
-
- # goto this link, then invoke the call-back.
-
- if {[info exists var(going)]} {
- $win yview N:$var(going)
- update
- HMwent_to $win $var(going)
- unset var(going)
- }
-
- if {[info exists var(Tname)]} {
- unset var(Tname)
- HMstack $win / "Tanchor anchor"
- }
-}
-
-# Inline Images
-# This interface is subject to change
-# Most of the work is getting around a limitation of TK that prevents
-# setting the size of a label to a widthxheight in pixels
-#
-# Images have the following parameters:
-# align: top,middle,bottom
-# alt: alternate text
-# ismap: A clickable image map
-# src: The URL link
-# Netscape supports (and so do we)
-# width: A width hint (in pixels)
-# height: A height hint (in pixels)
-# border: The size of the window border
-
-proc HMtag_img {win param text} {
- upvar #0 HM$win var
-
- # get alignment
- array set align_map {top top middle center bottom bottom}
- set align bottom ;# The spec isn't clear what the default should be
- HMextract_param $param align
- catch {set align $align_map([string tolower $align])}
-
- # get alternate text
- set alt "<image>"
- HMextract_param $param alt
- set alt [HMmap_esc $alt]
-
- # get the border width
- set border 1
- HMextract_param $param border
-
- # see if we have an image size hint
- # If so, make a frame the "hint" size to put the label in
- # otherwise just make the label
- set item $win.$var(tags)
- # catch {destroy $item}
- if {[HMextract_param $param width] && [HMextract_param $param height]} {
- frame $item -width $width -height $height
- pack propagate $item 0
- set label $item.label
- label $label
- pack $label -expand 1 -fill both
- } else {
- set label $item
- label $label
- }
-
- $label configure -relief ridge -fg orange -text $alt
- catch {$label configure -bd $border}
- $win window create $var(S_insert) -align $align -window $item -pady 2 -padx 2
-
- # add in all the current tags (this is overkill)
- set tags [HMcurrent_tags $win]
- foreach tag $tags {
- $win tag add $tag $item
- }
-
- # set imagemap callbacks
- if {[HMextract_param $param ismap]} {
- # regsub -all {[^L]*L:([^ ]*).*} $tags {\1} link
- set link [lindex $tags [lsearch -glob $tags L:*]]
- regsub L: $link {} link
- global HMevents
- regsub -all {%} $link {%%} link2
- foreach i [array names HMevents] {
- bind $label <$i> "catch \{%W configure $HMevents($i)\}"
- }
- bind $label <1> "+HMlink_callback $win $link2?%x,%y"
- }
-
- # now callback to the application
- set src ""
- HMextract_param $param src
- HMset_image $win $label $src
- return $label ;# used by the forms package for input_image types
-}
-
-# The app needs to supply one of these
-proc HMset_image {win handle src} {
- HMgot_image $handle "can't get\n$src"
-}
-
-# When the image is available, the application should call back here.
-# If we have the image, put it in the label, otherwise display the error
-# message. If we don't get a callback, the "alt" text remains.
-# if we have a clickable image, arrange for a callback
-
-proc HMgot_image {win image_error} {
- # if we're in a frame turn on geometry propogation
- if {[winfo name $win] == "label"} {
- pack propagate [winfo parent $win] 1
- }
- if {[catch {$win configure -image $image_error}]} {
- $win configure -image {}
- $win configure -text $image_error
- }
-}
-
-# Sample hypertext link callback routine - should be replaced by app
-# This proc is called once for each <A> tag.
-# Applications can overwrite this procedure, as required, or
-# replace the HMevents array
-# win: The name of the text widget to render into
-# href: The HREF link for this <a> tag.
-
-array set HMevents {
- Enter {-borderwidth 2 -relief raised }
- Leave {-borderwidth 2 -relief flat }
- 1 {-borderwidth 2 -relief sunken}
- ButtonRelease-1 {-borderwidth 2 -relief raised}
-}
-
-# We need to escape any %'s in the href tag name so the bind command
-# doesn't try to substitute them.
-
-proc HMlink_setup {win href} {
- global HMevents
- regsub -all {%} $href {%%} href2
- foreach i [array names HMevents] {
- eval {$win tag bind L:$href <$i>} \
- \{$win tag configure \{L:$href2\} $HMevents($i)\}
- }
-}
-
-# generic link-hit callback
-# This gets called upon button hits on hypertext links
-# Applications are expected to supply ther own HMlink_callback routine
-# win: The name of the text widget to render into
-# x,y: The cursor position at the "click"
-
-proc HMlink_hit {win x y} {
- set tags [$win tag names @$x,$y]
- set link [lindex $tags [lsearch -glob $tags L:*]]
- # regsub -all {[^L]*L:([^ ]*).*} $tags {\1} link
- regsub L: $link {} link
- HMlink_callback $win $link
-}
-
-# replace this!
-# win: The name of the text widget to render into
-# href: The HREF link for this <a> tag.
-
-proc HMlink_callback {win href} {
- puts "Got hit on $win, link $href"
-}
-
-# extract a value from parameter list (this needs a re-do)
-# returns "1" if the keyword is found, "0" otherwise
-# param: A parameter list. It should alredy have been processed to
-# remove any entity references
-# key: The parameter name
-# val: The variable to put the value into (use key as default)
-
-proc HMextract_param {param key {val ""}} {
-
- if {$val == ""} {
- upvar $key result
- } else {
- upvar $val result
- }
- set ws " \n\r"
-
- # look for name=value combinations. Either (') or (") are valid delimeters
- if {
- [regsub -nocase [format {.*%s[%s]*=[%s]*"([^"]*).*} $key $ws $ws] $param {\1} value] ||
- [regsub -nocase [format {.*%s[%s]*=[%s]*'([^']*).*} $key $ws $ws] $param {\1} value] ||
- [regsub -nocase [format {.*%s[%s]*=[%s]*([^%s]+).*} $key $ws $ws $ws] $param {\1} value] } {
- set result $value
- return 1
- }
-
- # now look for valueless names
- # I should strip out name=value pairs, so we don't end up with "name"
- # inside the "value" part of some other key word - some day
-
- set bad \[^a-zA-Z\]+
- if {[regexp -nocase "$bad$key$bad" -$param-]} {
- return 1
- } else {
- return 0
- }
-}
-
-# These next two routines manage the display state of the page.
-
-# Push or pop tags to/from stack.
-# Each orthogonal text property has its own stack, stored as a list.
-# The current (most recent) tag is the last item on the list.
-# Push is {} for pushing and {/} for popping
-
-proc HMstack {win push list} {
- upvar #0 HM$win var
- array set tags $list
- if {$push == ""} {
- foreach tag [array names tags] {
- lappend var($tag) $tags($tag)
- }
- } else {
- foreach tag [array names tags] {
- # set cnt [regsub { *[^ ]+$} $var($tag) {} var($tag)]
- set var($tag) [lreplace $var($tag) end end]
- }
- }
-}
-
-# extract set of current text tags
-# tags starting with T map directly to text tags, all others are
-# handled specially. There is an application callback, HMset_font
-# to allow the application to do font error handling
-
-proc HMcurrent_tags {win} {
- upvar #0 HM$win var
- set font font
- foreach i {family size weight style} {
- set $i [lindex $var($i) end]
- append font :[set $i]
- }
- set xfont [HMx_font $family $size $weight $style $var(S_adjust_size)]
- HMset_font $win $font $xfont
- set indent [llength $var(indent)]
- incr indent -1
- lappend tags $font indent$indent
- foreach tag [array names var T*] {
- lappend tags [lindex $var($tag) end] ;# test
- }
- set var(font) $font
- set var(xfont) [$win tag cget $font -font]
- set var(level) $indent
- return $tags
-}
-
-# allow the application to do do better font management
-# by overriding this procedure
-
-proc HMset_font {win tag font} {
- catch {$win tag configure $tag -font $font} msg
-}
-
-# generate an X font name
-proc HMx_font {family size weight style {adjust_size 0}} {
- catch {incr size $adjust_size}
- return "-*-$family-$weight-$style-normal-*-*-${size}0-*-*-*-*-*-*"
-}
-
-# Optimize HMrender (hee hee)
-# This is experimental
-
-proc HMoptimize {} {
- regsub -all "\n\[ \]*#\[^\n\]*" [info body HMrender] {} body
- regsub -all ";\[ \]*#\[^\n]*" $body {} body
- regsub -all "\n\n+" $body \n body
- proc HMrender {win tag not param text} $body
-}
-############################################
-# Turn HTML into TCL commands
-# html A string containing an html document
-# cmd A command to run for each html tag found
-# start The name of the dummy html start/stop tags
-
-proc HMparse_html {html {cmd HMtest_parse} {start hmstart}} {
- regsub -all \{ $html {\&ob;} html
- regsub -all \} $html {\&cb;} html
- set w " \t\r\n" ;# white space
- proc HMcl x {return "\[$x\]"}
- set exp <(/?)([HMcl ^$w>]+)[HMcl $w]*([HMcl ^>]*)>
- set sub "\}\n$cmd {\\2} {\\1} {\\3} \{"
- regsub -all $exp $html $sub html
- eval "$cmd {$start} {} {} \{ $html \}"
- eval "$cmd {$start} / {} {}"
-}
-
-proc HMtest_parse {command tag slash text_after_tag} {
- puts "==> $command $tag $slash $text_after_tag"
-}
-
-# Convert multiple white space into a single space
-
-proc HMzap_white {data} {
- regsub -all "\[ \t\r\n\]+" $data " " data
- return $data
-}
-
-# find HTML escape characters of the form &xxx;
-
-proc HMmap_esc {text} {
- if {![regexp & $text]} {return $text}
- regsub -all {([][$\\])} $text {\\\1} new
- regsub -all {&#([0-9][0-9]?[0-9]?);?} \
- $new {[format %c [scan \1 %d tmp;set tmp]]} new
- regsub -all {&([a-zA-Z]+);?} $new {[HMdo_map \1]} new
- return [subst $new]
-}
-
-# convert an HTML escape sequence into character
-
-proc HMdo_map {text {unknown ?}} {
- global HMesc_map
- set result $unknown
- catch {set result $HMesc_map($text)}
- return $result
-}
-
-# table of escape characters (ISO latin-1 esc's are in a different table)
-
-array set HMesc_map {
- lt < gt > amp & quot \" copy \xa9
- reg \xae ob \x7b cb \x7d nbsp \xa0
-}
-#############################################################
-# ISO Latin-1 escape codes
-
-array set HMesc_map {
- nbsp \xa0 iexcl \xa1 cent \xa2 pound \xa3 curren \xa4
- yen \xa5 brvbar \xa6 sect \xa7 uml \xa8 copy \xa9
- ordf \xaa laquo \xab not \xac shy \xad reg \xae
- hibar \xaf deg \xb0 plusmn \xb1 sup2 \xb2 sup3 \xb3
- acute \xb4 micro \xb5 para \xb6 middot \xb7 cedil \xb8
- sup1 \xb9 ordm \xba raquo \xbb frac14 \xbc frac12 \xbd
- frac34 \xbe iquest \xbf Agrave \xc0 Aacute \xc1 Acirc \xc2
- Atilde \xc3 Auml \xc4 Aring \xc5 AElig \xc6 Ccedil \xc7
- Egrave \xc8 Eacute \xc9 Ecirc \xca Euml \xcb Igrave \xcc
- Iacute \xcd Icirc \xce Iuml \xcf ETH \xd0 Ntilde \xd1
- Ograve \xd2 Oacute \xd3 Ocirc \xd4 Otilde \xd5 Ouml \xd6
- times \xd7 Oslash \xd8 Ugrave \xd9 Uacute \xda Ucirc \xdb
- Uuml \xdc Yacute \xdd THORN \xde szlig \xdf agrave \xe0
- aacute \xe1 acirc \xe2 atilde \xe3 auml \xe4 aring \xe5
- aelig \xe6 ccedil \xe7 egrave \xe8 eacute \xe9 ecirc \xea
- euml \xeb igrave \xec iacute \xed icirc \xee iuml \xef
- eth \xf0 ntilde \xf1 ograve \xf2 oacute \xf3 ocirc \xf4
- otilde \xf5 ouml \xf6 divide \xf7 oslash \xf8 ugrave \xf9
- uacute \xfa ucirc \xfb uuml \xfc yacute \xfd thorn \xfe
- yuml \xff
-}
-
-##########################################################
-# html forms management commands
-
-# As each form element is located, it is created and rendered. Additional
-# state is stored in a form specific global variable to be processed at
-# the end of the form, including the "reset" and "submit" options.
-# Remember, there can be multiple forms existing on multiple pages. When
-# HTML tables are added, a single form could be spread out over multiple
-# text widgets, which makes it impractical to hang the form state off the
-# HM$win structure. We don't need to check for the existance of required
-# parameters, we just "fail" and get caught in HMrender
-
-# This causes line breaks to be preserved in the inital values
-# of text areas
-array set HMtag_map {
- textarea {fill 0}
-}
-
-##########################################################
-# html isindex tag. Although not strictly forms, they're close enough
-# to be in this file
-
-# is-index forms
-# make a frame with a label, entry, and submit button
-
-proc HMtag_isindex {win param text} {
- upvar #0 HM$win var
-
- set item $win.$var(tags)
- if {[winfo exists $item]} {
- destroy $item
- }
- frame $item -relief ridge -bd 3
- set prompt "Enter search keywords here"
- HMextract_param $param prompt
- label $item.label -text [HMmap_esc $prompt] -font $var(xfont)
- entry $item.entry
- bind $item.entry <Return> "$item.submit invoke"
- button $item.submit -text search -font $var(xfont) -command \
- [format {HMsubmit_index %s {%s} [HMmap_reply [%s get]]} \
- $win $param $item.entry]
- pack $item.label -side top
- pack $item.entry $item.submit -side left
-
- # insert window into text widget
-
- $win insert $var(S_insert) \n isindex
- HMwin_install $win $item
- $win insert $var(S_insert) \n isindex
- bind $item <Visibility> {focus %W.entry}
-}
-
-# This is called when the isindex form is submitted.
-# The default version calls HMlink_callback. Isindex tags should either
-# be deprecated, or fully supported (e.g. they need an href parameter)
-
-proc HMsubmit_index {win param text} {
- HMlink_callback $win ?$text
-}
-
-# initialize form state. All of the state for this form is kept
-# in a global array whose name is stored in the form_id field of
-# the main window array.
-# Parameters: ACTION, METHOD, ENCTYPE
-
-proc HMtag_form {win param text} {
- upvar #0 HM$win var
-
- # create a global array for the form
- set id HM$win.form$var(tags)
- upvar #0 $id form
-
- # missing /form tag, simulate it
- if {[info exists var(form_id)]} {
- puts "Missing end-form tag !!!! $var(form_id)"
- HMtag_/form $win {} {}
- }
- catch {unset form}
- set var(form_id) $id
-
- set form(param) $param ;# form initial parameter list
- set form(reset) "" ;# command to reset the form
- set form(reset_button) "" ;# list of all reset buttons
- set form(submit) "" ;# command to submit the form
- set form(submit_button) "" ;# list of all submit buttons
-}
-
-# Where we're done try to get all of the state into the widgets so
-# we can free up the form structure here. Unfortunately, we can't!
-
-proc HMtag_/form {win param text} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
-
- # make submit button entries for all radio buttons
- foreach name [array names form radio_*] {
- regsub radio_ $name {} name
- lappend form(submit) [list $name \$form(radio_$name)]
- }
-
- # no submit button - add one
- if {$form(submit_button) == ""} {
- HMinput_submit $win {}
-
- }
-
- # process the "submit" command(s)
- # each submit button could have its own name,value pair
-
- foreach item $form(submit_button) {
- set submit $form(submit)
- catch {lappend submit $form(submit_$item)}
- $item configure -command \
- [list HMsubmit_button $win $var(form_id) $form(param) \
- $submit]
- }
-
- # process the reset button(s)
- HMinput_reset $win {}
- foreach item $form(reset_button) {
- $item configure -command $form(reset)
- }
-
- # unset all unused fields here
- unset form(reset) form(submit) form(reset_button) form(submit_button)
- unset var(form_id)
-}
-
-###################################################################
-# handle form input items
-# each item type is handled in a separate procedure
-# Each "type" procedure needs to:
-# - create the window
-# - initialize it
-# - add the "submit" and "reset" commands onto the proper Q's
-# "submit" is subst'd
-# "reset" is eval'd
-
-proc HMtag_input {win param text} {
- upvar #0 HM$win var
-
- set type text ;# the default
- HMextract_param $param type
- set type [string tolower $type]
- if {[catch {HMinput_$type $win $param} err]} {
- puts stderr $err
- }
-}
-
-# input type=text
-# parameters NAME (reqd), MAXLENGTH, SIZE, VALUE
-
-proc HMinput_text {win param {show {}}} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
-
- # make the entry
- HMextract_param $param name ;# required
- set item $win.input_text,$var(tags)
- set size 20; HMextract_param $param size
- set maxlength 0; HMextract_param $param maxlength
- entry $item -width $size -show $show
-
- # set the initial value
- set value ""; HMextract_param $param value
- $item insert 0 $value
-
- # insert the entry
- HMwin_install $win $item
-
- # set the "reset" and "submit" commands
- append form(reset) ";$item delete 0 end;$item insert 0 [list $value]"
- lappend form(submit) [list $name "\[$item get]"]
-
- # handle the maximum length (broken - no way to cleanup bindtags state)
- if {$maxlength} {
- bindtags $item "[bindtags $item] max$maxlength"
- bind max$maxlength <KeyPress> "%W delete $maxlength end"
- }
-}
-
-# password fields - same as text, only don't show data
-# parameters NAME (reqd), MAXLENGTH, SIZE, VALUE
-
-proc HMinput_password {win param} {
- HMinput_text $win $param *
-}
-
-# checkbuttons are missing a "get" option, so we must use a global
-# variable to store the value.
-# Parameters NAME, VALUE, (reqd), CHECKED
-
-proc HMinput_checkbox {win param} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
-
- HMextract_param $param name
- HMextract_param $param value
-
- # Set the global variable, don't use the "form" alias as it is not
- # defined in the global scope of the button
- set variable $var(form_id)(check_$var(tags))
- set item $win.input_checkbutton,$var(tags)
- checkbutton $item -variable $variable -off {} -on $value -text " "
- if {[HMextract_param $param checked]} {
- $item select
- append form(reset) ";$item select"
- } else {
- append form(reset) ";$item deselect"
- }
-
- HMwin_install $win $item
- lappend form(submit) [list $name \$form(check_$var(tags))]
-}
-
-# radio buttons. These are like check buttons, but only one can be selected
-
-proc HMinput_radio {win param} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
-
- HMextract_param $param name
- HMextract_param $param value
-
- set first [expr ![info exists form(radio_$name)]]
- set variable $var(form_id)(radio_$name)
- set variable $var(form_id)(radio_$name)
- set item $win.input_radiobutton,$var(tags)
- radiobutton $item -variable $variable -value $value -text " "
-
- HMwin_install $win $item
-
- if {$first || [HMextract_param $param checked]} {
- $item select
- append form(reset) ";$item select"
- } else {
- append form(reset) ";$item deselect"
- }
-
- # do the "submit" actions in /form so we only end up with 1 per button grouping
- # contributing to the submission
-}
-
-# hidden fields, just append to the "submit" data
-# params: NAME, VALUE (reqd)
-
-proc HMinput_hidden {win param} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
- HMextract_param $param name
- HMextract_param $param value
- lappend form(submit) [list $name $value]
-}
-
-# handle input images. The spec isn't very clear on these, so I'm not
-# sure its quite right
-# Use std image tag, only set up our own callbacks
-# (e.g. make sure ismap isn't set)
-# params: NAME, SRC (reqd) ALIGN
-
-proc HMinput_image {win param} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
- HMextract_param $param name
- set name ;# barf if no name is specified
- set item [HMtag_img $win $param {}]
- $item configure -relief raised -bd 2 -bg blue
-
- # make a dummy "submit" button, and invoke it to send the form.
- # We have to get the %x,%y in the value somehow, so calculate it during
- # binding, and save it in the form array for later processing
-
- set submit $win.dummy_submit,$var(tags)
- if {[winfo exists $submit]} {
- destroy $submit
- }
- button $submit -takefocus 0;# this never gets mapped!
- lappend form(submit_button) $submit
- set form(submit_$submit) [list $name $name.\$form(X).\$form(Y)]
-
- $item configure -takefocus 1
- bind $item <FocusIn> "catch \{$win see $item\}"
- bind $item <1> "$item configure -relief sunken"
- bind $item <Return> "
- set $var(form_id)(X) 0
- set $var(form_id)(Y) 0
- $submit invoke
- "
- bind $item <ButtonRelease-1> "
- set $var(form_id)(X) %x
- set $var(form_id)(Y) %y
- $item configure -relief raised
- $submit invoke
- "
-}
-
-# Set up the reset button. Wait for the /form to attach
-# the -command option. There could be more that 1 reset button
-# params VALUE
-
-proc HMinput_reset {win param} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
-
- set value reset
- HMextract_param $param value
-
- set item $win.input_reset,$var(tags)
- button $item -text [HMmap_esc $value] -cursor left_ptr
- HMwin_install $win $item
- lappend form(reset_button) $item
-}
-
-# Set up the submit button. Wait for the /form to attach
-# the -command option. There could be more that 1 submit button
-# params: NAME, VALUE
-
-proc HMinput_submit {win param} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
-
- HMextract_param $param name
- set value submit
- HMextract_param $param value
- set item $win.input_submit,$var(tags)
- button $item -text [HMmap_esc $value] -fg blue -cursor left_ptr
- HMwin_install $win $item
- lappend form(submit_button) $item
- # need to tie the "name=value" to this button
- # save the pair and do it when we finish the submit button
- catch {set form(submit_$item) [list $name $value]}
-}
-
-#########################################################################
-# selection items
-# They all go into a list box. We don't what to do with the listbox until
-# we know how many items end up in it. Gather up the data for the "options"
-# and finish up in the /select tag
-# params: NAME (reqd), MULTIPLE, SIZE
-
-proc HMtag_select {win param text} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
-
- HMextract_param $param name
- set size 5; HMextract_param $param size
- set form(select_size) $size
- set form(select_name) $name
- set form(select_values) "" ;# list of values to submit
- if {[HMextract_param $param multiple]} {
- set mode multiple
- } else {
- set mode single
- }
- set item $win.select,$var(tags)
- frame $item
- set form(select_frame) $item
- listbox $item.list -selectmode $mode -width 0 -exportselection 0 -cursor left_ptr
- HMwin_install $win $item
-}
-
-# select options
-# The values returned in the query may be different from those
-# displayed in the listbox, so we need to keep a separate list of
-# query values.
-# form(select_default) - contains the default query value
-# form(select_frame) - name of the listbox's containing frame
-# form(select_values) - list of query values
-# params: VALUE, SELECTED
-
-proc HMtag_option {win param text} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
- upvar $text data
- set frame $form(select_frame)
-
- # set default option (or options)
- if {[HMextract_param $param selected]} {
- lappend form(select_default) [$form(select_frame).list size]
- }
- set value [string trimright $data " \n"]
- $frame.list insert end $value
- HMextract_param $param value
- lappend form(select_values) $value
- set data ""
-}
-
-# do most of the work here!
-# if SIZE>1, make the listbox. Otherwise make a "drop-down"
-# listbox with a label in it
-# If the # of items > size, add a scroll bar
-# This should probably be broken up into callbacks to make it
-# easier to override the "look".
-
-proc HMtag_/select {win param text} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
- set frame $form(select_frame)
- set size $form(select_size)
- set items [$frame.list size]
-
- # set the defaults and reset button
- append form(reset) ";$frame.list selection clear 0 $items"
- if {[info exists form(select_default)]} {
- foreach i $form(select_default) {
- $frame.list selection set $i
- append form(reset) ";$frame.list selection set $i"
- }
- } else {
- $frame.list selection set 0
- append form(reset) ";$frame.list selection set 0"
- }
-
- # set up the submit button. This is the general case. For single
- # selections we could be smarter
-
- for {set i 0} {$i < $size} {incr i} {
- set value [format {[expr {[%s selection includes %s] ? {%s} : {}}]} \
- $frame.list $i [lindex $form(select_values) $i]]
- lappend form(submit) [list $form(select_name) $value]
- }
-
- # show the listbox - no scroll bar
-
- if {$size > 1 && $items <= $size} {
- $frame.list configure -height $items
- pack $frame.list
-
- # Listbox with scrollbar
-
- } elseif {$size > 1} {
- scrollbar $frame.scroll -command "$frame.list yview" \
- -orient v -takefocus 0
- $frame.list configure -height $size \
- -yscrollcommand "$frame.scroll set"
- pack $frame.list $frame.scroll -side right -fill y
-
- # This is a joke!
-
- } else {
- scrollbar $frame.scroll -command "$frame.list yview" \
- -orient h -takefocus 0
- $frame.list configure -height 1 \
- -yscrollcommand "$frame.scroll set"
- pack $frame.list $frame.scroll -side top -fill x
- }
-
- # cleanup
-
- foreach i [array names form select_*] {
- unset form($i)
- }
-}
-
-# do a text area (multi-line text)
-# params: COLS, NAME, ROWS (all reqd, but default rows and cols anyway)
-
-proc HMtag_textarea {win param text} {
- upvar #0 HM$win var
- upvar #0 $var(form_id) form
- upvar $text data
-
- set rows 5; HMextract_param $param rows
- set cols 30; HMextract_param $param cols
- HMextract_param $param name
- set item $win.textarea,$var(tags)
- frame $item
- text $item.text -width $cols -height $rows -wrap none \
- -yscrollcommand "$item.scroll set" -padx 3 -pady 3
- scrollbar $item.scroll -command "$item.text yview" -orient v
- $item.text insert 1.0 $data
- HMwin_install $win $item
- pack $item.text $item.scroll -side right -fill y
- lappend form(submit) [list $name "\[$item.text get 0.0 end]"]
- append form(reset) ";$item.text delete 1.0 end; \
- $item.text insert 1.0 [list $data]"
- set data ""
-}
-
-# procedure to install windows into the text widget
-# - win: name of the text widget
-# - item: name of widget to install
-
-proc HMwin_install {win item} {
- upvar #0 HM$win var
- $win window create $var(S_insert) -window $item -align bottom
- $win tag add indent$var(level) $item
- set focus [expr {[winfo class $item] != "Frame"}]
- $item configure -takefocus $focus
- bind $item <FocusIn> "$win see $item"
-}
-
-#####################################################################
-# Assemble and submit the query
-# each list element in "stuff" is a name/value pair
-# - The names are the NAME parameters of the various fields
-# - The values get run through "subst" to extract the values
-# - We do the user callback with the list of name value pairs
-
-proc HMsubmit_button {win form_id param stuff} {
- upvar #0 HM$win var
- upvar #0 $form_id form
- set query ""
- foreach pair $stuff {
- set value [subst [lindex $pair 1]]
- #if {$value != ""} {
- set item [lindex $pair 0]
- lappend query $item $value
- #}
- }
- # this is the user callback.
- HMsubmit_form $win $param $query
-}
-
-# sample user callback for form submission
-# should be replaced by the application
-# Sample version generates a string suitable for http
-
-proc HMsubmit_form {win param query} {
- set result ""
- set sep ""
- foreach i $query {
- append result $sep [HMmap_reply $i]
- if {$sep != "="} {set sep =} {set sep &}
- }
- puts $result
-}
-
-# do x-www-urlencoded character mapping
-# The spec says: "non-alphanumeric characters are replaced by '%HH'"
-
-set HMalphanumeric a-zA-Z0-9 ;# definition of alphanumeric character class
-for {set i 1} {$i <= 256} {incr i} {
- set c [format %c $i]
- if {![string match \[$HMalphanumeric\] $c]} {
- set HMform_map($c) %[format %.2x $i]
- }
-}
-
-# These are handled specially
-array set HMform_map {
- " " + \n %0d%0a
-}
-
-# 1 leave alphanumerics characters alone
-# 2 Convert every other character to an array lookup
-# 3 Escape constructs that are "special" to the tcl parser
-# 4 "subst" the result, doing all the array substitutions
-
-proc HMmap_reply {string} {
- global HMform_map HMalphanumeric
- regsub -all \[^$HMalphanumeric\] $string {$HMform_map(&)} string
- regsub -all \n $string {\\n} string
- regsub -all \t $string {\\t} string
- regsub -all {[][{})\\]\)} $string {\\&} string
- return [subst $string]
-}
-
-# convert a x-www-urlencoded string int a a list of name/value pairs
-
-# 1 convert a=b&c=d... to {a} {b} {c} {d}...
-# 2, convert + to " "
-# 3, convert %xx to char equiv
-
-proc HMcgiDecode {data} {
- set data [split $data "&="]
- foreach i $data {
- lappend result [cgiMap $i]
- }
- return $result
-}
-
-proc HMcgiMap {data} {
- regsub -all {\+} $data " " data
-
- if {[regexp % $data]} {
- regsub -all {([][$\\])} $data {\\\1} data
- regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data
- return [subst $data]
- } else {
- return $data
- }
-}
-
-# There is a bug in the tcl library focus routines that prevents focus
-# from every reaching an un-viewable window. Use our *own*
-# version of the library routine, until the bug is fixed, make sure we
-# over-ride the library version, and not the otherway around
-
-auto_load tkFocusOK
-proc tkFocusOK w {
- set code [catch {$w cget -takefocus} value]
- if {($code == 0) && ($value != "")} {
- if {$value == 0} {
- return 0
- } elseif {$value == 1} {
- return 1
- } else {
- set value [uplevel #0 $value $w]
- if {$value != ""} {
- return $value
- }
- }
- }
- set code [catch {$w cget -state} value]
- if {($code == 0) && ($value == "disabled")} {
- return 0
- }
- regexp Key|Focus "[bind $w] [bind [winfo class $w]]"
-}
Copied: grass/trunk/lib/form/html_library_grass.tcl (from rev 35193, grass/trunk/lib/form/html_library_grass.tcl)
===================================================================
--- grass/trunk/lib/form/html_library_grass.tcl (rev 0)
+++ grass/trunk/lib/form/html_library_grass.tcl 2009-01-04 15:47:39 UTC (rev 35199)
@@ -0,0 +1,1418 @@
+# Simple HTML display library by Stephen Uhler (stephen.uhler at sun.com)
+# Copyright (c) 1995 by Sun Microsystems
+# Version 0.3 Fri Sep 1 10:47:17 PDT 1995
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# To use this package, create a text widget (say, .text)
+# and set a variable full of html, (say $html), and issue:
+# HMinit_win .text
+# HMparse_html $html "HMrender .text"
+# You also need to supply the routine:
+# proc HMlink_callback {win href} { ...}
+# win: The name of the text widget
+# href The name of the link
+# which will be called anytime the user "clicks" on a link.
+# The supplied version just prints the link to stdout.
+# In addition, if you wish to use embedded images, you will need to write
+# proc HMset_image {handle src}
+# handle an arbitrary handle (not really)
+# src The name of the image
+# Which calls
+# HMgot_image $handle $image
+# with the TK image.
+#
+# To return a "used" text widget to its initialized state, call:
+# HMreset_win .text
+# See "sample.tcl" for sample usage
+##################################################################
+############################################
+# mapping of html tags to text tag properties
+# properties beginning with "T" map directly to text tags
+
+# These are Defined in HTML 2.0
+
+array set HMtag_map {
+ b {weight bold}
+ blockquote {style i indent 1 Trindent rindent}
+ bq {style i indent 1 Trindent rindent}
+ cite {style i}
+ code {family courier}
+ dfn {style i}
+ dir {indent 1}
+ dl {indent 1}
+ em {style i}
+ h1 {size 24 weight bold}
+ h2 {size 22}
+ h3 {size 20}
+ h4 {size 18}
+ h5 {size 16}
+ h6 {style i}
+ i {style i}
+ kbd {family courier weight bold}
+ menu {indent 1}
+ ol {indent 1}
+ pre {fill 0 family courier Tnowrap nowrap}
+ samp {family courier}
+ strong {weight bold}
+ tt {family courier}
+ u {Tunderline underline}
+ ul {indent 1}
+ var {style i}
+}
+
+# These are in common(?) use, but not defined in html2.0
+
+array set HMtag_map {
+ center {Tcenter center}
+ strike {Tstrike strike}
+ u {Tunderline underline}
+}
+
+# initial values
+
+set HMtag_map(hmstart) {
+ family times weight medium style r size 14
+ Tcenter "" Tlink "" Tnowrap "" Tunderline "" list list
+ fill 1 indent "" counter 0 adjust 0
+}
+
+# html tags that insert white space
+
+array set HMinsert_map {
+ blockquote "\n\n" /blockquote "\n"
+ br "\n"
+ dd "\n" /dd "\n"
+ dl "\n" /dl "\n"
+ dt "\n"
+ form "\n" /form "\n"
+ h1 "\n\n" /h1 "\n"
+ h2 "\n\n" /h2 "\n"
+ h3 "\n\n" /h3 "\n"
+ h4 "\n" /h4 "\n"
+ h5 "\n" /h5 "\n"
+ h6 "\n" /h6 "\n"
+ li "\n"
+ /dir "\n"
+ /ul "\n"
+ /ol "\n"
+ /menu "\n"
+ p "\n\n"
+ pre "\n" /pre "\n"
+}
+
+# tags that are list elements, that support "compact" rendering
+
+array set HMlist_elements {
+ ol 1 ul 1 menu 1 dl 1 dir 1
+}
+############################################
+# initialize the window and stack state
+
+proc HMinit_win {win} {
+ upvar #0 HM$win var
+
+ HMinit_state $win
+ $win tag configure underline -underline 1
+ $win tag configure center -justify center
+ $win tag configure nowrap -wrap none
+ $win tag configure rindent -rmargin $var(S_tab)c
+ $win tag configure strike -overstrike 1
+ $win tag configure mark -foreground red ;# list markers
+ $win tag configure list -spacing1 3p -spacing3 3p ;# regular lists
+ $win tag configure compact -spacing1 0p ;# compact lists
+ $win tag configure link -borderwidth 2 -foreground blue ;# hypertext links
+ HMset_indent $win $var(S_tab)
+ $win configure -wrap word
+
+ # configure the text insertion point
+ $win mark set $var(S_insert) 1.0
+
+ # for horizontal rules
+ $win tag configure thin -font [HMx_font times 2 medium r]
+ $win tag configure hr -relief sunken -borderwidth 2 -wrap none \
+ -tabs [winfo width $win]
+ bind $win <Configure> {
+ %W tag configure hr -tabs %w
+ %W tag configure last -spacing3 %h
+ }
+
+ # generic link enter callback
+
+ $win tag bind link <1> "HMlink_hit $win %x %y"
+}
+
+# set the indent spacing (in cm) for lists
+# TK uses a "weird" tabbing model that causes \t to insert a single
+# space if the current line position is past the tab setting
+
+proc HMset_indent {win cm} {
+ set tabs [expr $cm / 2.0]
+ $win configure -tabs ${tabs}c
+ foreach i {1 2 3 4 5 6 7 8 9} {
+ set tab [expr $i * $cm]
+ $win tag configure indent$i -lmargin1 ${tab}c -lmargin2 ${tab}c \
+ -tabs "[expr $tab + $tabs]c [expr $tab + 2*$tabs]c"
+ }
+}
+
+# reset the state of window - get ready for the next page
+# remove all but the font tags, and remove all form state
+
+proc HMreset_win {win} {
+ upvar #0 HM$win var
+ regsub -all { +[^L ][^ ]*} " [$win tag names] " {} tags
+ catch "$win tag delete $tags"
+ eval $win mark unset [$win mark names]
+ $win delete 0.0 end
+ $win tag configure hr -tabs [winfo width $win]
+
+ # configure the text insertion point
+ $win mark set $var(S_insert) 1.0
+
+ # remove form state. If any check/radio buttons still exists,
+ # their variables will be magically re-created, and never get
+ # cleaned up.
+ catch unset [info globals HM$win.form*]
+
+ HMinit_state $win
+ return HM$win
+}
+
+# initialize the window's state array
+# Parameters beginning with S_ are NOT reset
+# adjust_size: global font size adjuster
+# unknown: character to use for unknown entities
+# tab: tab stop (in cm)
+# stop: enabled to stop processing
+# update: how many tags between update calls
+# tags: number of tags processed so far
+# symbols: Symbols to use on un-ordered lists
+
+proc HMinit_state {win} {
+ upvar #0 HM$win var
+ array set tmp [array get var S_*]
+ catch {unset var}
+ array set var {
+ stop 0
+ tags 0
+ fill 0
+ list list
+ S_adjust_size 0
+ S_tab 1.0
+ S_unknown \xb7
+ S_update 10
+ S_symbols O*=+-o\xd7\xb0>:\xb7
+ S_insert Insert
+ }
+ array set var [array get tmp]
+}
+
+# alter the parameters of the text state
+# this allows an application to over-ride the default settings
+# it is called as: HMset_state -param value -param value ...
+
+array set HMparam_map {
+ -update S_update
+ -tab S_tab
+ -unknown S_unknown
+ -stop S_stop
+ -size S_adjust_size
+ -symbols S_symbols
+ -insert S_insert
+}
+
+proc HMset_state {win args} {
+ upvar #0 HM$win var
+ global HMparam_map
+ set bad 0
+ if {[catch {array set params $args}]} {return 0}
+ foreach i [array names params] {
+ incr bad [catch {set var($HMparam_map($i)) $params($i)}]
+ }
+ return [expr $bad == 0]
+}
+
+############################################
+# manage the display of html
+
+# HMrender gets called for every html tag
+# win: The name of the text widget to render into
+# tag: The html tag (in arbitrary case)
+# not: a "/" or the empty string
+# param: The un-interpreted parameter list
+# text: The plain text until the next html tag
+
+proc HMrender {win tag not param text} {
+ upvar #0 HM$win var
+ if {$var(stop)} return
+ global HMtag_map HMinsert_map HMlist_elements
+ set tag [string tolower $tag]
+ set text [HMmap_esc $text]
+
+ # manage compact rendering of lists
+ if {[info exists HMlist_elements($tag)]} {
+ set list "list [expr {[HMextract_param $param compact] ? "compact" : "list"}]"
+ } else {
+ set list ""
+ }
+
+ # Allow text to be diverted to a different window (for tables)
+ # this is not currently used
+ if {[info exists var(divert)]} {
+ set win $var(divert)
+ upvar #0 HM$win var
+ }
+
+ # adjust (push or pop) tag state
+ catch {HMstack $win $not "$HMtag_map($tag) $list"}
+
+ # insert white space (with current font)
+ # adding white space can get a bit tricky. This isn't quite right
+ set bad [catch {$win insert $var(S_insert) $HMinsert_map($not$tag) "space $var(font)"}]
+ if {!$bad && [lindex $var(fill) end]} {
+ set text [string trimleft $text]
+ }
+
+ # to fill or not to fill
+ if {[lindex $var(fill) end]} {
+ set text [HMzap_white $text]
+ }
+
+ # generic mark hook
+ catch {HMmark $not$tag $win $param text} err
+
+ # do any special tag processing
+ catch {HMtag_$not$tag $win $param text} msg
+
+
+ # add the text with proper tags
+
+ set tags [HMcurrent_tags $win]
+ $win insert $var(S_insert) $text $tags
+
+ # We need to do an update every so often to insure interactive response.
+ # This can cause us to re-enter the event loop, and cause recursive
+ # invocations of HMrender, so we need to be careful.
+ if {!([incr var(tags)] % $var(S_update))} {
+ update
+ }
+}
+
+# html tags requiring special processing
+# Procs of the form HMtag_<tag> or HMtag_</tag> get called just before
+# the text for this tag is displayed. These procs are called inside a
+# "catch" so it is OK to fail.
+# win: The name of the text widget to render into
+# param: The un-interpreted parameter list
+# text: A pass-by-reference name of the plain text until the next html tag
+# Tag commands may change this to affect what text will be inserted
+# next.
+
+# A pair of pseudo tags are added automatically as the 1st and last html
+# tags in the document. The default is <HMstart> and </HMstart>.
+# Append enough blank space at the end of the text widget while
+# rendering so HMgoto can place the target near the top of the page,
+# then remove the extra space when done rendering.
+
+proc HMtag_hmstart {win param text} {
+ upvar #0 HM$win var
+ $win mark gravity $var(S_insert) left
+ $win insert end "\n " last
+ $win mark gravity $var(S_insert) right
+}
+
+proc HMtag_/hmstart {win param text} {
+ $win delete last.first end
+}
+
+# put the document title in the window banner, and remove the title text
+# from the document
+
+proc HMtag_title {win param text} {
+ upvar $text data
+ wm title [winfo toplevel $win] $data
+ set data ""
+}
+
+proc HMtag_hr {win param text} {
+ upvar #0 HM$win var
+ $win insert $var(S_insert) "\n" space "\n" thin "\t" "thin hr" "\n" thin
+}
+
+# list element tags
+
+proc HMtag_ol {win param text} {
+ upvar #0 HM$win var
+ set var(count$var(level)) 0
+}
+
+proc HMtag_ul {win param text} {
+ upvar #0 HM$win var
+ catch {unset var(count$var(level))}
+}
+
+proc HMtag_menu {win param text} {
+ upvar #0 HM$win var
+ set var(menu) ->
+ set var(compact) 1
+}
+
+proc HMtag_/menu {win param text} {
+ upvar #0 HM$win var
+ catch {unset var(menu)}
+ catch {unset var(compact)}
+}
+
+proc HMtag_dt {win param text} {
+ upvar #0 HM$win var
+ upvar $text data
+ set level $var(level)
+ incr level -1
+ $win insert $var(S_insert) "$data" \
+ "hi [lindex $var(list) end] indent$level $var(font)"
+ set data {}
+}
+
+proc HMtag_li {win param text} {
+ upvar #0 HM$win var
+ set level $var(level)
+ incr level -1
+ set x [string index $var(S_symbols)+-+-+-+-" $level]
+ catch {set x [incr var(count$level)]}
+ catch {set x $var(menu)}
+ $win insert $var(S_insert) \t$x\t "mark [lindex $var(list) end] indent$level $var(font)"
+}
+
+# Manage hypertext "anchor" links. A link can be either a source (href)
+# a destination (name) or both. If its a source, register it via a callback,
+# and set its default behavior. If its a destination, check to see if we need
+# to go there now, as a result of a previous HMgoto request. If so, schedule
+# it to happen with the closing </a> tag, so we can highlight the text up to
+# the </a>.
+
+proc HMtag_a {win param text} {
+ upvar #0 HM$win var
+
+ # a source
+
+ if {[HMextract_param $param href]} {
+ set var(Tref) [list L:$href]
+ HMstack $win "" "Tlink link"
+ HMlink_setup $win $href
+ }
+
+ # a destination
+
+ if {[HMextract_param $param name]} {
+ set var(Tname) [list N:$name]
+ HMstack $win "" "Tanchor anchor"
+ $win mark set N:$name "$var(S_insert) - 1 chars"
+ $win mark gravity N:$name left
+ if {[info exists var(goto)] && $var(goto) == $name} {
+ unset var(goto)
+ set var(going) $name
+ }
+ }
+}
+
+# The application should call here with the fragment name
+# to cause the display to go to this spot.
+# If the target exists, go there (and do the callback),
+# otherwise schedule the goto to happen when we see the reference.
+
+proc HMgoto {win where {callback HMwent_to}} {
+ upvar #0 HM$win var
+ if {[regexp N:$where [$win mark names]]} {
+ $win see N:$where
+ update
+ eval $callback $win [list $where]
+ return 1
+ } else {
+ set var(goto) $where
+ return 0
+ }
+}
+
+# We actually got to the spot, so highlight it!
+# This should/could be replaced by the application
+# We'll flash it orange a couple of times.
+
+proc HMwent_to {win where {count 0} {color orange}} {
+ upvar #0 HM$win var
+ if {$count > 5} return
+ catch {$win tag configure N:$where -foreground $color}
+ update
+ after 200 [list HMwent_to $win $where [incr count] \
+ [expr {$color=="orange" ? "" : "orange"}]]
+}
+
+proc HMtag_/a {win param text} {
+ upvar #0 HM$win var
+ if {[info exists var(Tref)]} {
+ unset var(Tref)
+ HMstack $win / "Tlink link"
+ }
+
+ # goto this link, then invoke the call-back.
+
+ if {[info exists var(going)]} {
+ $win yview N:$var(going)
+ update
+ HMwent_to $win $var(going)
+ unset var(going)
+ }
+
+ if {[info exists var(Tname)]} {
+ unset var(Tname)
+ HMstack $win / "Tanchor anchor"
+ }
+}
+
+# Inline Images
+# This interface is subject to change
+# Most of the work is getting around a limitation of TK that prevents
+# setting the size of a label to a widthxheight in pixels
+#
+# Images have the following parameters:
+# align: top,middle,bottom
+# alt: alternate text
+# ismap: A clickable image map
+# src: The URL link
+# Netscape supports (and so do we)
+# width: A width hint (in pixels)
+# height: A height hint (in pixels)
+# border: The size of the window border
+
+proc HMtag_img {win param text} {
+ upvar #0 HM$win var
+
+ # get alignment
+ array set align_map {top top middle center bottom bottom}
+ set align bottom ;# The spec isn't clear what the default should be
+ HMextract_param $param align
+ catch {set align $align_map([string tolower $align])}
+
+ # get alternate text
+ set alt "<image>"
+ HMextract_param $param alt
+ set alt [HMmap_esc $alt]
+
+ # get the border width
+ set border 1
+ HMextract_param $param border
+
+ # see if we have an image size hint
+ # If so, make a frame the "hint" size to put the label in
+ # otherwise just make the label
+ set item $win.$var(tags)
+ # catch {destroy $item}
+ if {[HMextract_param $param width] && [HMextract_param $param height]} {
+ frame $item -width $width -height $height
+ pack propagate $item 0
+ set label $item.label
+ label $label
+ pack $label -expand 1 -fill both
+ } else {
+ set label $item
+ label $label
+ }
+
+ $label configure -relief ridge -fg orange -text $alt
+ catch {$label configure -bd $border}
+ $win window create $var(S_insert) -align $align -window $item -pady 2 -padx 2
+
+ # add in all the current tags (this is overkill)
+ set tags [HMcurrent_tags $win]
+ foreach tag $tags {
+ $win tag add $tag $item
+ }
+
+ # set imagemap callbacks
+ if {[HMextract_param $param ismap]} {
+ # regsub -all {[^L]*L:([^ ]*).*} $tags {\1} link
+ set link [lindex $tags [lsearch -glob $tags L:*]]
+ regsub L: $link {} link
+ global HMevents
+ regsub -all {%} $link {%%} link2
+ foreach i [array names HMevents] {
+ bind $label <$i> "catch \{%W configure $HMevents($i)\}"
+ }
+ bind $label <1> "+HMlink_callback $win $link2?%x,%y"
+ }
+
+ # now callback to the application
+ set src ""
+ HMextract_param $param src
+ HMset_image $win $label $src
+ return $label ;# used by the forms package for input_image types
+}
+
+# The app needs to supply one of these
+proc HMset_image {win handle src} {
+ HMgot_image $handle "can't get\n$src"
+}
+
+# When the image is available, the application should call back here.
+# If we have the image, put it in the label, otherwise display the error
+# message. If we don't get a callback, the "alt" text remains.
+# if we have a clickable image, arrange for a callback
+
+proc HMgot_image {win image_error} {
+ # if we're in a frame turn on geometry propogation
+ if {[winfo name $win] == "label"} {
+ pack propagate [winfo parent $win] 1
+ }
+ if {[catch {$win configure -image $image_error}]} {
+ $win configure -image {}
+ $win configure -text $image_error
+ }
+}
+
+# Sample hypertext link callback routine - should be replaced by app
+# This proc is called once for each <A> tag.
+# Applications can overwrite this procedure, as required, or
+# replace the HMevents array
+# win: The name of the text widget to render into
+# href: The HREF link for this <a> tag.
+
+array set HMevents {
+ Enter {-borderwidth 2 -relief raised }
+ Leave {-borderwidth 2 -relief flat }
+ 1 {-borderwidth 2 -relief sunken}
+ ButtonRelease-1 {-borderwidth 2 -relief raised}
+}
+
+# We need to escape any %'s in the href tag name so the bind command
+# doesn't try to substitute them.
+
+proc HMlink_setup {win href} {
+ global HMevents
+ regsub -all {%} $href {%%} href2
+ foreach i [array names HMevents] {
+ eval {$win tag bind L:$href <$i>} \
+ \{$win tag configure \{L:$href2\} $HMevents($i)\}
+ }
+}
+
+# generic link-hit callback
+# This gets called upon button hits on hypertext links
+# Applications are expected to supply ther own HMlink_callback routine
+# win: The name of the text widget to render into
+# x,y: The cursor position at the "click"
+
+proc HMlink_hit {win x y} {
+ set tags [$win tag names @$x,$y]
+ set link [lindex $tags [lsearch -glob $tags L:*]]
+ # regsub -all {[^L]*L:([^ ]*).*} $tags {\1} link
+ regsub L: $link {} link
+ HMlink_callback $win $link
+}
+
+# replace this!
+# win: The name of the text widget to render into
+# href: The HREF link for this <a> tag.
+
+proc HMlink_callback {win href} {
+ puts "Got hit on $win, link $href"
+}
+
+# extract a value from parameter list (this needs a re-do)
+# returns "1" if the keyword is found, "0" otherwise
+# param: A parameter list. It should alredy have been processed to
+# remove any entity references
+# key: The parameter name
+# val: The variable to put the value into (use key as default)
+
+proc HMextract_param {param key {val ""}} {
+
+ if {$val == ""} {
+ upvar $key result
+ } else {
+ upvar $val result
+ }
+ set ws " \n\r"
+
+ # look for name=value combinations. Either (') or (") are valid delimeters
+ if {
+ [regsub -nocase [format {.*%s[%s]*=[%s]*"([^"]*).*} $key $ws $ws] $param {\1} value] ||
+ [regsub -nocase [format {.*%s[%s]*=[%s]*'([^']*).*} $key $ws $ws] $param {\1} value] ||
+ [regsub -nocase [format {.*%s[%s]*=[%s]*([^%s]+).*} $key $ws $ws $ws] $param {\1} value] } {
+ set result $value
+ return 1
+ }
+
+ # now look for valueless names
+ # I should strip out name=value pairs, so we don't end up with "name"
+ # inside the "value" part of some other key word - some day
+
+ set bad \[^a-zA-Z\]+
+ if {[regexp -nocase "$bad$key$bad" -$param-]} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+# These next two routines manage the display state of the page.
+
+# Push or pop tags to/from stack.
+# Each orthogonal text property has its own stack, stored as a list.
+# The current (most recent) tag is the last item on the list.
+# Push is {} for pushing and {/} for popping
+
+proc HMstack {win push list} {
+ upvar #0 HM$win var
+ array set tags $list
+ if {$push == ""} {
+ foreach tag [array names tags] {
+ lappend var($tag) $tags($tag)
+ }
+ } else {
+ foreach tag [array names tags] {
+ # set cnt [regsub { *[^ ]+$} $var($tag) {} var($tag)]
+ set var($tag) [lreplace $var($tag) end end]
+ }
+ }
+}
+
+# extract set of current text tags
+# tags starting with T map directly to text tags, all others are
+# handled specially. There is an application callback, HMset_font
+# to allow the application to do font error handling
+
+proc HMcurrent_tags {win} {
+ upvar #0 HM$win var
+ set font font
+ foreach i {family size weight style} {
+ set $i [lindex $var($i) end]
+ append font :[set $i]
+ }
+ set xfont [HMx_font $family $size $weight $style $var(S_adjust_size)]
+ HMset_font $win $font $xfont
+ set indent [llength $var(indent)]
+ incr indent -1
+ lappend tags $font indent$indent
+ foreach tag [array names var T*] {
+ lappend tags [lindex $var($tag) end] ;# test
+ }
+ set var(font) $font
+ set var(xfont) [$win tag cget $font -font]
+ set var(level) $indent
+ return $tags
+}
+
+# allow the application to do do better font management
+# by overriding this procedure
+
+proc HMset_font {win tag font} {
+ catch {$win tag configure $tag -font $font} msg
+}
+
+# generate an X font name
+proc HMx_font {family size weight style {adjust_size 0}} {
+ catch {incr size $adjust_size}
+ return "-*-$family-$weight-$style-normal-*-*-${size}0-*-*-*-*-*-*"
+}
+
+# Optimize HMrender (hee hee)
+# This is experimental
+
+proc HMoptimize {} {
+ regsub -all "\n\[ \]*#\[^\n\]*" [info body HMrender] {} body
+ regsub -all ";\[ \]*#\[^\n]*" $body {} body
+ regsub -all "\n\n+" $body \n body
+ proc HMrender {win tag not param text} $body
+}
+############################################
+# Turn HTML into TCL commands
+# html A string containing an html document
+# cmd A command to run for each html tag found
+# start The name of the dummy html start/stop tags
+
+proc HMparse_html {html {cmd HMtest_parse} {start hmstart}} {
+ regsub -all \{ $html {\&ob;} html
+ regsub -all \} $html {\&cb;} html
+ set w " \t\r\n" ;# white space
+ proc HMcl x {return "\[$x\]"}
+ set exp <(/?)([HMcl ^$w>]+)[HMcl $w]*([HMcl ^>]*)>
+ set sub "\}\n$cmd {\\2} {\\1} {\\3} \{"
+ regsub -all $exp $html $sub html
+ eval "$cmd {$start} {} {} \{ $html \}"
+ eval "$cmd {$start} / {} {}"
+}
+
+proc HMtest_parse {command tag slash text_after_tag} {
+ puts "==> $command $tag $slash $text_after_tag"
+}
+
+# Convert multiple white space into a single space
+
+proc HMzap_white {data} {
+ regsub -all "\[ \t\r\n\]+" $data " " data
+ return $data
+}
+
+# find HTML escape characters of the form &xxx;
+
+proc HMmap_esc {text} {
+ if {![regexp & $text]} {return $text}
+ regsub -all {([][$\\])} $text {\\\1} new
+ regsub -all {&#([0-9][0-9]?[0-9]?);?} \
+ $new {[format %c [scan \1 %d tmp;set tmp]]} new
+ regsub -all {&([a-zA-Z]+);?} $new {[HMdo_map \1]} new
+ return [subst $new]
+}
+
+# convert an HTML escape sequence into character
+
+proc HMdo_map {text {unknown ?}} {
+ global HMesc_map
+ set result $unknown
+ catch {set result $HMesc_map($text)}
+ return $result
+}
+
+# table of escape characters (ISO latin-1 esc's are in a different table)
+
+array set HMesc_map {
+ lt < gt > amp & quot \" copy \xa9
+ reg \xae ob \x7b cb \x7d nbsp \xa0
+}
+#############################################################
+# ISO Latin-1 escape codes
+
+array set HMesc_map {
+ nbsp \xa0 iexcl \xa1 cent \xa2 pound \xa3 curren \xa4
+ yen \xa5 brvbar \xa6 sect \xa7 uml \xa8 copy \xa9
+ ordf \xaa laquo \xab not \xac shy \xad reg \xae
+ hibar \xaf deg \xb0 plusmn \xb1 sup2 \xb2 sup3 \xb3
+ acute \xb4 micro \xb5 para \xb6 middot \xb7 cedil \xb8
+ sup1 \xb9 ordm \xba raquo \xbb frac14 \xbc frac12 \xbd
+ frac34 \xbe iquest \xbf Agrave \xc0 Aacute \xc1 Acirc \xc2
+ Atilde \xc3 Auml \xc4 Aring \xc5 AElig \xc6 Ccedil \xc7
+ Egrave \xc8 Eacute \xc9 Ecirc \xca Euml \xcb Igrave \xcc
+ Iacute \xcd Icirc \xce Iuml \xcf ETH \xd0 Ntilde \xd1
+ Ograve \xd2 Oacute \xd3 Ocirc \xd4 Otilde \xd5 Ouml \xd6
+ times \xd7 Oslash \xd8 Ugrave \xd9 Uacute \xda Ucirc \xdb
+ Uuml \xdc Yacute \xdd THORN \xde szlig \xdf agrave \xe0
+ aacute \xe1 acirc \xe2 atilde \xe3 auml \xe4 aring \xe5
+ aelig \xe6 ccedil \xe7 egrave \xe8 eacute \xe9 ecirc \xea
+ euml \xeb igrave \xec iacute \xed icirc \xee iuml \xef
+ eth \xf0 ntilde \xf1 ograve \xf2 oacute \xf3 ocirc \xf4
+ otilde \xf5 ouml \xf6 divide \xf7 oslash \xf8 ugrave \xf9
+ uacute \xfa ucirc \xfb uuml \xfc yacute \xfd thorn \xfe
+ yuml \xff
+}
+
+##########################################################
+# html forms management commands
+
+# As each form element is located, it is created and rendered. Additional
+# state is stored in a form specific global variable to be processed at
+# the end of the form, including the "reset" and "submit" options.
+# Remember, there can be multiple forms existing on multiple pages. When
+# HTML tables are added, a single form could be spread out over multiple
+# text widgets, which makes it impractical to hang the form state off the
+# HM$win structure. We don't need to check for the existance of required
+# parameters, we just "fail" and get caught in HMrender
+
+# This causes line breaks to be preserved in the inital values
+# of text areas
+array set HMtag_map {
+ textarea {fill 0}
+}
+
+##########################################################
+# html isindex tag. Although not strictly forms, they're close enough
+# to be in this file
+
+# is-index forms
+# make a frame with a label, entry, and submit button
+
+proc HMtag_isindex {win param text} {
+ upvar #0 HM$win var
+
+ set item $win.$var(tags)
+ if {[winfo exists $item]} {
+ destroy $item
+ }
+ frame $item -relief ridge -bd 3
+ set prompt "Enter search keywords here"
+ HMextract_param $param prompt
+ label $item.label -text [HMmap_esc $prompt] -font $var(xfont)
+ entry $item.entry
+ bind $item.entry <Return> "$item.submit invoke"
+ button $item.submit -text search -font $var(xfont) -command \
+ [format {HMsubmit_index %s {%s} [HMmap_reply [%s get]]} \
+ $win $param $item.entry]
+ pack $item.label -side top
+ pack $item.entry $item.submit -side left
+
+ # insert window into text widget
+
+ $win insert $var(S_insert) \n isindex
+ HMwin_install $win $item
+ $win insert $var(S_insert) \n isindex
+ bind $item <Visibility> {focus %W.entry}
+}
+
+# This is called when the isindex form is submitted.
+# The default version calls HMlink_callback. Isindex tags should either
+# be deprecated, or fully supported (e.g. they need an href parameter)
+
+proc HMsubmit_index {win param text} {
+ HMlink_callback $win ?$text
+}
+
+# initialize form state. All of the state for this form is kept
+# in a global array whose name is stored in the form_id field of
+# the main window array.
+# Parameters: ACTION, METHOD, ENCTYPE
+
+proc HMtag_form {win param text} {
+ upvar #0 HM$win var
+
+ # create a global array for the form
+ set id HM$win.form$var(tags)
+ upvar #0 $id form
+
+ # missing /form tag, simulate it
+ if {[info exists var(form_id)]} {
+ puts "Missing end-form tag !!!! $var(form_id)"
+ HMtag_/form $win {} {}
+ }
+ catch {unset form}
+ set var(form_id) $id
+
+ set form(param) $param ;# form initial parameter list
+ set form(reset) "" ;# command to reset the form
+ set form(reset_button) "" ;# list of all reset buttons
+ set form(submit) "" ;# command to submit the form
+ set form(submit_button) "" ;# list of all submit buttons
+}
+
+# Where we're done try to get all of the state into the widgets so
+# we can free up the form structure here. Unfortunately, we can't!
+
+proc HMtag_/form {win param text} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+
+ # make submit button entries for all radio buttons
+ foreach name [array names form radio_*] {
+ regsub radio_ $name {} name
+ lappend form(submit) [list $name \$form(radio_$name)]
+ }
+
+ # no submit button - add one
+ if {$form(submit_button) == ""} {
+ HMinput_submit $win {}
+
+ }
+
+ # process the "submit" command(s)
+ # each submit button could have its own name,value pair
+
+ foreach item $form(submit_button) {
+ set submit $form(submit)
+ catch {lappend submit $form(submit_$item)}
+ $item configure -command \
+ [list HMsubmit_button $win $var(form_id) $form(param) \
+ $submit]
+ }
+
+ # process the reset button(s)
+ HMinput_reset $win {}
+ foreach item $form(reset_button) {
+ $item configure -command $form(reset)
+ }
+
+ # unset all unused fields here
+ unset form(reset) form(submit) form(reset_button) form(submit_button)
+ unset var(form_id)
+}
+
+###################################################################
+# handle form input items
+# each item type is handled in a separate procedure
+# Each "type" procedure needs to:
+# - create the window
+# - initialize it
+# - add the "submit" and "reset" commands onto the proper Q's
+# "submit" is subst'd
+# "reset" is eval'd
+
+proc HMtag_input {win param text} {
+ upvar #0 HM$win var
+
+ set type text ;# the default
+ HMextract_param $param type
+ set type [string tolower $type]
+ if {[catch {HMinput_$type $win $param} err]} {
+ puts stderr $err
+ }
+}
+
+# input type=text
+# parameters NAME (reqd), MAXLENGTH, SIZE, VALUE
+
+proc HMinput_text {win param {show {}}} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+
+ # make the entry
+ HMextract_param $param name ;# required
+ set item $win.input_text,$var(tags)
+ set size 20; HMextract_param $param size
+ set maxlength 0; HMextract_param $param maxlength
+ entry $item -width $size -show $show
+
+ # set the initial value
+ set value ""; HMextract_param $param value
+ $item insert 0 $value
+
+ # insert the entry
+ HMwin_install $win $item
+
+ # set the "reset" and "submit" commands
+ append form(reset) ";$item delete 0 end;$item insert 0 [list $value]"
+ lappend form(submit) [list $name "\[$item get]"]
+
+ # handle the maximum length (broken - no way to cleanup bindtags state)
+ if {$maxlength} {
+ bindtags $item "[bindtags $item] max$maxlength"
+ bind max$maxlength <KeyPress> "%W delete $maxlength end"
+ }
+}
+
+# password fields - same as text, only don't show data
+# parameters NAME (reqd), MAXLENGTH, SIZE, VALUE
+
+proc HMinput_password {win param} {
+ HMinput_text $win $param *
+}
+
+# checkbuttons are missing a "get" option, so we must use a global
+# variable to store the value.
+# Parameters NAME, VALUE, (reqd), CHECKED
+
+proc HMinput_checkbox {win param} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+
+ HMextract_param $param name
+ HMextract_param $param value
+
+ # Set the global variable, don't use the "form" alias as it is not
+ # defined in the global scope of the button
+ set variable $var(form_id)(check_$var(tags))
+ set item $win.input_checkbutton,$var(tags)
+ checkbutton $item -variable $variable -off {} -on $value -text " "
+ if {[HMextract_param $param checked]} {
+ $item select
+ append form(reset) ";$item select"
+ } else {
+ append form(reset) ";$item deselect"
+ }
+
+ HMwin_install $win $item
+ lappend form(submit) [list $name \$form(check_$var(tags))]
+}
+
+# radio buttons. These are like check buttons, but only one can be selected
+
+proc HMinput_radio {win param} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+
+ HMextract_param $param name
+ HMextract_param $param value
+
+ set first [expr ![info exists form(radio_$name)]]
+ set variable $var(form_id)(radio_$name)
+ set variable $var(form_id)(radio_$name)
+ set item $win.input_radiobutton,$var(tags)
+ radiobutton $item -variable $variable -value $value -text " "
+
+ HMwin_install $win $item
+
+ if {$first || [HMextract_param $param checked]} {
+ $item select
+ append form(reset) ";$item select"
+ } else {
+ append form(reset) ";$item deselect"
+ }
+
+ # do the "submit" actions in /form so we only end up with 1 per button grouping
+ # contributing to the submission
+}
+
+# hidden fields, just append to the "submit" data
+# params: NAME, VALUE (reqd)
+
+proc HMinput_hidden {win param} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+ HMextract_param $param name
+ HMextract_param $param value
+ lappend form(submit) [list $name $value]
+}
+
+# handle input images. The spec isn't very clear on these, so I'm not
+# sure its quite right
+# Use std image tag, only set up our own callbacks
+# (e.g. make sure ismap isn't set)
+# params: NAME, SRC (reqd) ALIGN
+
+proc HMinput_image {win param} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+ HMextract_param $param name
+ set name ;# barf if no name is specified
+ set item [HMtag_img $win $param {}]
+ $item configure -relief raised -bd 2 -bg blue
+
+ # make a dummy "submit" button, and invoke it to send the form.
+ # We have to get the %x,%y in the value somehow, so calculate it during
+ # binding, and save it in the form array for later processing
+
+ set submit $win.dummy_submit,$var(tags)
+ if {[winfo exists $submit]} {
+ destroy $submit
+ }
+ button $submit -takefocus 0;# this never gets mapped!
+ lappend form(submit_button) $submit
+ set form(submit_$submit) [list $name $name.\$form(X).\$form(Y)]
+
+ $item configure -takefocus 1
+ bind $item <FocusIn> "catch \{$win see $item\}"
+ bind $item <1> "$item configure -relief sunken"
+ bind $item <Return> "
+ set $var(form_id)(X) 0
+ set $var(form_id)(Y) 0
+ $submit invoke
+ "
+ bind $item <ButtonRelease-1> "
+ set $var(form_id)(X) %x
+ set $var(form_id)(Y) %y
+ $item configure -relief raised
+ $submit invoke
+ "
+}
+
+# Set up the reset button. Wait for the /form to attach
+# the -command option. There could be more that 1 reset button
+# params VALUE
+
+proc HMinput_reset {win param} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+
+ set value reset
+ HMextract_param $param value
+
+ set item $win.input_reset,$var(tags)
+ button $item -text [HMmap_esc $value] -cursor left_ptr
+ HMwin_install $win $item
+ lappend form(reset_button) $item
+}
+
+# Set up the submit button. Wait for the /form to attach
+# the -command option. There could be more that 1 submit button
+# params: NAME, VALUE
+
+proc HMinput_submit {win param} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+
+ HMextract_param $param name
+ set value submit
+ HMextract_param $param value
+ set item $win.input_submit,$var(tags)
+ button $item -text [HMmap_esc $value] -fg blue -cursor left_ptr
+ HMwin_install $win $item
+ lappend form(submit_button) $item
+ # need to tie the "name=value" to this button
+ # save the pair and do it when we finish the submit button
+ catch {set form(submit_$item) [list $name $value]}
+}
+
+#########################################################################
+# selection items
+# They all go into a list box. We don't what to do with the listbox until
+# we know how many items end up in it. Gather up the data for the "options"
+# and finish up in the /select tag
+# params: NAME (reqd), MULTIPLE, SIZE
+
+proc HMtag_select {win param text} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+
+ HMextract_param $param name
+ set size 5; HMextract_param $param size
+ set form(select_size) $size
+ set form(select_name) $name
+ set form(select_values) "" ;# list of values to submit
+ if {[HMextract_param $param multiple]} {
+ set mode multiple
+ } else {
+ set mode single
+ }
+ set item $win.select,$var(tags)
+ frame $item
+ set form(select_frame) $item
+ listbox $item.list -selectmode $mode -width 0 -exportselection 0 -cursor left_ptr
+ HMwin_install $win $item
+}
+
+# select options
+# The values returned in the query may be different from those
+# displayed in the listbox, so we need to keep a separate list of
+# query values.
+# form(select_default) - contains the default query value
+# form(select_frame) - name of the listbox's containing frame
+# form(select_values) - list of query values
+# params: VALUE, SELECTED
+
+proc HMtag_option {win param text} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+ upvar $text data
+ set frame $form(select_frame)
+
+ # set default option (or options)
+ if {[HMextract_param $param selected]} {
+ lappend form(select_default) [$form(select_frame).list size]
+ }
+ set value [string trimright $data " \n"]
+ $frame.list insert end $value
+ HMextract_param $param value
+ lappend form(select_values) $value
+ set data ""
+}
+
+# do most of the work here!
+# if SIZE>1, make the listbox. Otherwise make a "drop-down"
+# listbox with a label in it
+# If the # of items > size, add a scroll bar
+# This should probably be broken up into callbacks to make it
+# easier to override the "look".
+
+proc HMtag_/select {win param text} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+ set frame $form(select_frame)
+ set size $form(select_size)
+ set items [$frame.list size]
+
+ # set the defaults and reset button
+ append form(reset) ";$frame.list selection clear 0 $items"
+ if {[info exists form(select_default)]} {
+ foreach i $form(select_default) {
+ $frame.list selection set $i
+ append form(reset) ";$frame.list selection set $i"
+ }
+ } else {
+ $frame.list selection set 0
+ append form(reset) ";$frame.list selection set 0"
+ }
+
+ # set up the submit button. This is the general case. For single
+ # selections we could be smarter
+
+ for {set i 0} {$i < $size} {incr i} {
+ set value [format {[expr {[%s selection includes %s] ? {%s} : {}}]} \
+ $frame.list $i [lindex $form(select_values) $i]]
+ lappend form(submit) [list $form(select_name) $value]
+ }
+
+ # show the listbox - no scroll bar
+
+ if {$size > 1 && $items <= $size} {
+ $frame.list configure -height $items
+ pack $frame.list
+
+ # Listbox with scrollbar
+
+ } elseif {$size > 1} {
+ scrollbar $frame.scroll -command "$frame.list yview" \
+ -orient v -takefocus 0
+ $frame.list configure -height $size \
+ -yscrollcommand "$frame.scroll set"
+ pack $frame.list $frame.scroll -side right -fill y
+
+ # This is a joke!
+
+ } else {
+ scrollbar $frame.scroll -command "$frame.list yview" \
+ -orient h -takefocus 0
+ $frame.list configure -height 1 \
+ -yscrollcommand "$frame.scroll set"
+ pack $frame.list $frame.scroll -side top -fill x
+ }
+
+ # cleanup
+
+ foreach i [array names form select_*] {
+ unset form($i)
+ }
+}
+
+# do a text area (multi-line text)
+# params: COLS, NAME, ROWS (all reqd, but default rows and cols anyway)
+
+proc HMtag_textarea {win param text} {
+ upvar #0 HM$win var
+ upvar #0 $var(form_id) form
+ upvar $text data
+
+ set rows 5; HMextract_param $param rows
+ set cols 30; HMextract_param $param cols
+ HMextract_param $param name
+ set item $win.textarea,$var(tags)
+ frame $item
+ text $item.text -width $cols -height $rows -wrap none \
+ -yscrollcommand "$item.scroll set" -padx 3 -pady 3
+ scrollbar $item.scroll -command "$item.text yview" -orient v
+ $item.text insert 1.0 $data
+ HMwin_install $win $item
+ pack $item.text $item.scroll -side right -fill y
+ lappend form(submit) [list $name "\[$item.text get 0.0 end]"]
+ append form(reset) ";$item.text delete 1.0 end; \
+ $item.text insert 1.0 [list $data]"
+ set data ""
+}
+
+# procedure to install windows into the text widget
+# - win: name of the text widget
+# - item: name of widget to install
+
+proc HMwin_install {win item} {
+ upvar #0 HM$win var
+ $win window create $var(S_insert) -window $item -align bottom
+ $win tag add indent$var(level) $item
+ set focus [expr {[winfo class $item] != "Frame"}]
+ $item configure -takefocus $focus
+ bind $item <FocusIn> "$win see $item"
+}
+
+#####################################################################
+# Assemble and submit the query
+# each list element in "stuff" is a name/value pair
+# - The names are the NAME parameters of the various fields
+# - The values get run through "subst" to extract the values
+# - We do the user callback with the list of name value pairs
+
+proc HMsubmit_button {win form_id param stuff} {
+ upvar #0 HM$win var
+ upvar #0 $form_id form
+ set query ""
+ foreach pair $stuff {
+ set value [subst [lindex $pair 1]]
+ #if {$value != ""} {
+ set item [lindex $pair 0]
+ lappend query $item $value
+ #}
+ }
+ # this is the user callback.
+ HMsubmit_form $win $param $query
+}
+
+# sample user callback for form submission
+# should be replaced by the application
+# Sample version generates a string suitable for http
+
+proc HMsubmit_form {win param query} {
+ set result ""
+ set sep ""
+ foreach i $query {
+ append result $sep [HMmap_reply $i]
+ if {$sep != "="} {set sep =} {set sep &}
+ }
+ puts $result
+}
+
+# do x-www-urlencoded character mapping
+# The spec says: "non-alphanumeric characters are replaced by '%HH'"
+
+set HMalphanumeric a-zA-Z0-9 ;# definition of alphanumeric character class
+for {set i 1} {$i <= 256} {incr i} {
+ set c [format %c $i]
+ if {![string match \[$HMalphanumeric\] $c]} {
+ set HMform_map($c) %[format %.2x $i]
+ }
+}
+
+# These are handled specially
+array set HMform_map {
+ " " + \n %0d%0a
+}
+
+# 1 leave alphanumerics characters alone
+# 2 Convert every other character to an array lookup
+# 3 Escape constructs that are "special" to the tcl parser
+# 4 "subst" the result, doing all the array substitutions
+
+proc HMmap_reply {string} {
+ global HMform_map HMalphanumeric
+ regsub -all \[^$HMalphanumeric\] $string {$HMform_map(&)} string
+ regsub -all \n $string {\\n} string
+ regsub -all \t $string {\\t} string
+ regsub -all {[][{})\\]\)} $string {\\&} string
+ return [subst $string]
+}
+
+# convert a x-www-urlencoded string int a a list of name/value pairs
+
+# 1 convert a=b&c=d... to {a} {b} {c} {d}...
+# 2, convert + to " "
+# 3, convert %xx to char equiv
+
+proc HMcgiDecode {data} {
+ set data [split $data "&="]
+ foreach i $data {
+ lappend result [cgiMap $i]
+ }
+ return $result
+}
+
+proc HMcgiMap {data} {
+ regsub -all {\+} $data " " data
+
+ if {[regexp % $data]} {
+ regsub -all {([][$\\])} $data {\\\1} data
+ regsub -all {%([0-9a-fA-F][0-9a-fA-F])} $data {[format %c 0x\1]} data
+ return [subst $data]
+ } else {
+ return $data
+ }
+}
+
+# There is a bug in the tcl library focus routines that prevents focus
+# from every reaching an un-viewable window. Use our *own*
+# version of the library routine, until the bug is fixed, make sure we
+# over-ride the library version, and not the otherway around
+
+auto_load tkFocusOK
+proc tkFocusOK w {
+ set code [catch {$w cget -takefocus} value]
+ if {($code == 0) && ($value != "")} {
+ if {$value == 0} {
+ return 0
+ } elseif {$value == 1} {
+ return 1
+ } else {
+ set value [uplevel #0 $value $w]
+ if {$value != ""} {
+ return $value
+ }
+ }
+ }
+ set code [catch {$w cget -state} value]
+ if {($code == 0) && ($value == "disabled")} {
+ return 0
+ }
+ regexp Key|Focus "[bind $w] [bind [winfo class $w]]"
+}
Deleted: grass/trunk/lib/form/license.terms
===================================================================
--- grass/trunk/lib/form/license.terms 2009-01-04 14:37:12 UTC (rev 35193)
+++ grass/trunk/lib/form/license.terms 2009-01-04 15:47:39 UTC (rev 35199)
@@ -1,31 +0,0 @@
-Sun Microsystems, Inc. The following terms apply to all files
-associated with the software unless explicitly disclaimed in individual
-files.
-
-The authors hereby grant permission to use, copy, modify, distribute,
-and license this software and its documentation for any purpose, provided
-that existing copyright notices are retained in all copies and that this
-notice is included verbatim in any distributions. No written agreement,
-license, or royalty fee is required for any of the authorized uses.
-Modifications to this software may be copyrighted by their authors
-and need not follow the licensing terms described here, provided that
-the new terms are clearly indicated on the first page of each file where
-they apply.
-
-IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
-FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
-ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
-DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
-POSSIBILITY OF SUCH DAMAGE.
-
-THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
-INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
-FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
-IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
-NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
-MODIFICATIONS.
-
-RESTRICTED RIGHTS: Use, duplication or disclosure by the government
-is subject to the restrictions as set forth in subparagraph (c) (1) (ii)
-of the Rights in Technical Data and Computer Software Clause as DFARS
-252.227-7013 and FAR 52.227-19.
Copied: grass/trunk/lib/form/license.terms (from rev 35193, grass/trunk/lib/form/license.terms)
===================================================================
--- grass/trunk/lib/form/license.terms (rev 0)
+++ grass/trunk/lib/form/license.terms 2009-01-04 15:47:39 UTC (rev 35199)
@@ -0,0 +1,31 @@
+Sun Microsystems, Inc. The following terms apply to all files
+associated with the software unless explicitly disclaimed in individual
+files.
+
+The authors hereby grant permission to use, copy, modify, distribute,
+and license this software and its documentation for any purpose, provided
+that existing copyright notices are retained in all copies and that this
+notice is included verbatim in any distributions. No written agreement,
+license, or royalty fee is required for any of the authorized uses.
+Modifications to this software may be copyrighted by their authors
+and need not follow the licensing terms described here, provided that
+the new terms are clearly indicated on the first page of each file where
+they apply.
+
+IN NO EVENT SHALL THE AUTHORS OR DISTRIBUTORS BE LIABLE TO ANY PARTY
+FOR DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES
+ARISING OUT OF THE USE OF THIS SOFTWARE, ITS DOCUMENTATION, OR ANY
+DERIVATIVES THEREOF, EVEN IF THE AUTHORS HAVE BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
+
+THE AUTHORS AND DISTRIBUTORS SPECIFICALLY DISCLAIM ANY WARRANTIES,
+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE, AND NON-INFRINGEMENT. THIS SOFTWARE
+IS PROVIDED ON AN "AS IS" BASIS, AND THE AUTHORS AND DISTRIBUTORS HAVE
+NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR
+MODIFICATIONS.
+
+RESTRICTED RIGHTS: Use, duplication or disclosure by the government
+is subject to the restrictions as set forth in subparagraph (c) (1) (ii)
+of the Rights in Technical Data and Computer Software Clause as DFARS
+252.227-7013 and FAR 52.227-19.
Deleted: grass/trunk/lib/form/open.c
===================================================================
--- grass/trunk/lib/form/open.c 2009-01-04 14:37:12 UTC (rev 35193)
+++ grass/trunk/lib/form/open.c 2009-01-04 15:47:39 UTC (rev 35199)
@@ -1,203 +0,0 @@
-#include <stdlib.h>
-#include <string.h>
-#include <unistd.h>
-#include <fcntl.h>
-#include <grass/gis.h>
-#include <grass/dbmi.h>
-#include <grass/form.h>
-
-#ifdef HAVE_SOCKET
-#include <sys/types.h>
-#ifdef __MINGW32__
-#include <winsock.h>
-
-#else /*__MINGW32__*/
-#include <sys/socket.h>
-#include <netinet/in.h>
-
-#endif /*__MINGW32__*/
-#endif /*HAVE_SOCKET */
-
-#ifdef HAVE_SOCKET
-static int make_socketpair(int *);
-#endif
-
-int first = 1;
-
-/* the pipe to send data to GUI */
-FILE *parent_send, *parent_recv;
-
-#ifdef HAVE_SOCKET
-int pipefd[2];
-
-#define pfd pipefd[1] /* parent's end */
-#define cfd pipefd[0] /* child's end */
-
-#endif /*HAVE_SOCKET */
-
-/* Open new form
- *
- * returns: 0 success
- */
-#ifdef __MINGW32__
-int F_open(char *title, char *html)
-{
- G_fatal_error("F_open is not supported on Windows");
- return 1;
-}
-#else
-int F_open(char *title, char *html)
-{
- /* parent */
- int c;
-
- /* common */
- static int pid;
-
-#ifndef HAVE_SOCKET
- static int p1[2], p2[2];
-#endif /*HAVE_SOCKET */
- int length;
-
- /* child */
-
- G_debug(2, "F_open(): title = %s", title);
-
- if (first) {
-#ifdef HAVE_SOCKET
- if (make_socketpair(pipefd) < 0)
- G_fatal_error("Cannot make socket pair");
-#else
- if (pipe(p1) < 0 || pipe(p2) < 0)
- G_fatal_error("Cannot open pipe");
-#endif /*HAVE_SOCKET */
-
- if ((pid = fork()) < 0)
- G_fatal_error("Cannot create fork");
- }
-
- if (pid == 0) { /* Child */
- char command[2000], script[2000];
-
- G_debug(2, "CHILD");
-
- /* Note: If you are forking in a Tk based apllication you
- * must execl before doing any window operations in the
- * child or you will receive an error from the X server */
-
- close(0);
- close(1);
-
-#ifndef HAVE_SOCKET
- close(p1[1]);
- close(p2[0]);
- if (dup(p1[0]) != 0)
- G_fatal_error("Form: cannot dup() input");
- if (dup(p2[1]) != 1)
- G_fatal_error("Form: cannot dup() output");
-
-#else
- close(pfd);
- if (dup(cfd) != 0)
- G_fatal_error("Form: cannot dup() input");
- if (dup(cfd) != 1)
- G_fatal_error("Form: cannot dup() output");
-
-#endif /*HAVE_SOCKET */
-
-
-
- sprintf(command, "%s/etc/form/form", G_gisbase());
- sprintf(script, "%s/etc/form/form.tcl", G_gisbase());
-
- execl(command, "form", "-f", script, NULL);
-
- G_debug(2, "CHILD END\n");
- exit(0);
-
- }
- else { /* Parent */
- G_debug(2, "PARENT");
-
- if (first) {
-#ifndef HAVE_SOCKET
- parent_send = fdopen(p1[1], "w");
- close(p1[0]);
- parent_recv = fdopen(p2[0], "r");
- close(p2[1]);
-#else
- close(cfd);
- parent_send = fdopen(pfd, "w");
- parent_recv = fdopen(pfd, "r");
-#endif /*HAVE_SOCKET */
- first = 0;
- }
-
- G_debug(2, "PARENT HTML:\n%s\n", html);
-
- fprintf(parent_send, "O");
- length = strlen(title);
- fprintf(parent_send, "%d\n", length);
- fprintf(parent_send, "%s", title);
- length = strlen(html);
- fprintf(parent_send, "%d\n", length);
- fprintf(parent_send, "%s", html);
- fflush(parent_send);
- G_debug(2, "PARENT: Request sent\n");
-
- /* Wait for response */
- c = fgetc(parent_recv);
- G_debug(2, "PARENT: received %c\n", c);
- }
-
- return 0;
-}
-#endif
-
-/* Clear old forms from window
- *
- */
-void F_clear(void)
-{
- char c;
-
- G_debug(2, "F_clear()");
-
- if (first)
- return;
-
- fprintf(parent_send, "C");
- fflush(parent_send);
- c = fgetc(parent_recv);
- G_debug(2, "PARENT: received %c\n", c);
-}
-
-void F_close(void)
-{
- char c;
-
- G_debug(2, "F_close()");
-
- if (first)
- return;
-
- fprintf(parent_send, "D");
- fflush(parent_send);
- c = fgetc(parent_recv);
- G_debug(2, "PARENT: received %c\n", c);
-
- first = 1;
-}
-
-#ifdef HAVE_SOCKET
-static int make_socketpair(int *fd)
-{
- int n;
-
- if ((n = socketpair(AF_UNIX, SOCK_STREAM, IPPROTO_IP, fd)) < 0)
- return -1;
- else
- return 0;
-}
-
-#endif
Copied: grass/trunk/lib/form/open.c (from rev 35193, grass/trunk/lib/form/open.c)
===================================================================
--- grass/trunk/lib/form/open.c (rev 0)
+++ grass/trunk/lib/form/open.c 2009-01-04 15:47:39 UTC (rev 35199)
@@ -0,0 +1,203 @@
+#include <stdlib.h>
+#include <string.h>
+#include <unistd.h>
+#include <fcntl.h>
+#include <grass/gis.h>
+#include <grass/dbmi.h>
+#include <grass/form.h>
+
+#ifdef HAVE_SOCKET
+#include <sys/types.h>
+#ifdef __MINGW32__
+#include <winsock.h>
+
+#else /*__MINGW32__*/
+#include <sys/socket.h>
+#include <netinet/in.h>
+
+#endif /*__MINGW32__*/
+#endif /*HAVE_SOCKET */
+
+#ifdef HAVE_SOCKET
+static int make_socketpair(int *);
+#endif
+
+int first = 1;
+
+/* the pipe to send data to GUI */
+FILE *parent_send, *parent_recv;
+
+#ifdef HAVE_SOCKET
+int pipefd[2];
+
+#define pfd pipefd[1] /* parent's end */
+#define cfd pipefd[0] /* child's end */
+
+#endif /*HAVE_SOCKET */
+
+/* Open new form
+ *
+ * returns: 0 success
+ */
+#ifdef __MINGW32__
+int F_open(char *title, char *html)
+{
+ G_fatal_error("F_open is not supported on Windows");
+ return 1;
+}
+#else
+int F_open(char *title, char *html)
+{
+ /* parent */
+ int c;
+
+ /* common */
+ static int pid;
+
+#ifndef HAVE_SOCKET
+ static int p1[2], p2[2];
+#endif /*HAVE_SOCKET */
+ int length;
+
+ /* child */
+
+ G_debug(2, "F_open(): title = %s", title);
+
+ if (first) {
+#ifdef HAVE_SOCKET
+ if (make_socketpair(pipefd) < 0)
+ G_fatal_error("Cannot make socket pair");
+#else
+ if (pipe(p1) < 0 || pipe(p2) < 0)
+ G_fatal_error("Cannot open pipe");
+#endif /*HAVE_SOCKET */
+
+ if ((pid = fork()) < 0)
+ G_fatal_error("Cannot create fork");
+ }
+
+ if (pid == 0) { /* Child */
+ char command[2000], script[2000];
+
+ G_debug(2, "CHILD");
+
+ /* Note: If you are forking in a Tk based apllication you
+ * must execl before doing any window operations in the
+ * child or you will receive an error from the X server */
+
+ close(0);
+ close(1);
+
+#ifndef HAVE_SOCKET
+ close(p1[1]);
+ close(p2[0]);
+ if (dup(p1[0]) != 0)
+ G_fatal_error("Form: cannot dup() input");
+ if (dup(p2[1]) != 1)
+ G_fatal_error("Form: cannot dup() output");
+
+#else
+ close(pfd);
+ if (dup(cfd) != 0)
+ G_fatal_error("Form: cannot dup() input");
+ if (dup(cfd) != 1)
+ G_fatal_error("Form: cannot dup() output");
+
+#endif /*HAVE_SOCKET */
+
+
+
+ sprintf(command, "%s/etc/form/form", G_gisbase());
+ sprintf(script, "%s/etc/form/form.tcl", G_gisbase());
+
+ execl(command, "form", "-f", script, NULL);
+
+ G_debug(2, "CHILD END\n");
+ exit(0);
+
+ }
+ else { /* Parent */
+ G_debug(2, "PARENT");
+
+ if (first) {
+#ifndef HAVE_SOCKET
+ parent_send = fdopen(p1[1], "w");
+ close(p1[0]);
+ parent_recv = fdopen(p2[0], "r");
+ close(p2[1]);
+#else
+ close(cfd);
+ parent_send = fdopen(pfd, "w");
+ parent_recv = fdopen(pfd, "r");
+#endif /*HAVE_SOCKET */
+ first = 0;
+ }
+
+ G_debug(2, "PARENT HTML:\n%s\n", html);
+
+ fprintf(parent_send, "O");
+ length = strlen(title);
+ fprintf(parent_send, "%d\n", length);
+ fprintf(parent_send, "%s", title);
+ length = strlen(html);
+ fprintf(parent_send, "%d\n", length);
+ fprintf(parent_send, "%s", html);
+ fflush(parent_send);
+ G_debug(2, "PARENT: Request sent\n");
+
+ /* Wait for response */
+ c = fgetc(parent_recv);
+ G_debug(2, "PARENT: received %c\n", c);
+ }
+
+ return 0;
+}
+#endif
+
+/* Clear old forms from window
+ *
+ */
+void F_clear(void)
+{
+ char c;
+
+ G_debug(2, "F_clear()");
+
+ if (first)
+ return;
+
+ fprintf(parent_send, "C");
+ fflush(parent_send);
+ c = fgetc(parent_recv);
+ G_debug(2, "PARENT: received %c\n", c);
+}
+
+void F_close(void)
+{
+ char c;
+
+ G_debug(2, "F_close()");
+
+ if (first)
+ return;
+
+ fprintf(parent_send, "D");
+ fflush(parent_send);
+ c = fgetc(parent_recv);
+ G_debug(2, "PARENT: received %c\n", c);
+
+ first = 1;
+}
+
+#ifdef HAVE_SOCKET
+static int make_socketpair(int *fd)
+{
+ int n;
+
+ if ((n = socketpair(AF_UNIX, SOCK_STREAM, IPPROTO_IP, fd)) < 0)
+ return -1;
+ else
+ return 0;
+}
+
+#endif
Deleted: grass/trunk/lib/form/todo
===================================================================
--- grass/trunk/lib/form/todo 2009-01-04 14:37:12 UTC (rev 35193)
+++ grass/trunk/lib/form/todo 2009-01-04 15:47:39 UTC (rev 35199)
@@ -1,3 +0,0 @@
-Support special characters:
-< > " &
-in form entries.
Copied: grass/trunk/lib/form/todo (from rev 35193, grass/trunk/lib/form/todo)
===================================================================
--- grass/trunk/lib/form/todo (rev 0)
+++ grass/trunk/lib/form/todo 2009-01-04 15:47:39 UTC (rev 35199)
@@ -0,0 +1,3 @@
+Support special characters:
+< > " &
+in form entries.
More information about the grass-commit
mailing list