summaryrefslogtreecommitdiff
path: root/libgui/src
diff options
context:
space:
mode:
Diffstat (limited to 'libgui/src')
-rw-r--r--libgui/src/Makefile.in9
-rw-r--r--libgui/src/subcommand.c4
-rw-r--r--libgui/src/tclgetdir.c6
-rw-r--r--libgui/src/tclhelp.c43
-rw-r--r--libgui/src/tclmain.c2
-rw-r--r--libgui/src/tclmsgbox.c18
-rw-r--r--libgui/src/tclsizebox.c4
-rw-r--r--libgui/src/tclwinmode.c4
-rw-r--r--libgui/src/tclwinpath.c4
-rw-r--r--libgui/src/tclwinprint.c8
-rw-r--r--libgui/src/tkCanvEdge.c21
-rw-r--r--libgui/src/tkGraphCanvas.c6
-rw-r--r--libgui/src/tkTable.tcl.h366
-rw-r--r--libgui/src/tkTableCellSort.c400
-rw-r--r--libgui/src/tkTableCmds.c1293
-rw-r--r--libgui/src/tkTableEdit.c683
-rw-r--r--libgui/src/tkTableInitScript.h90
-rw-r--r--libgui/src/tkTablePs.c1299
-rw-r--r--libgui/src/tkTableUtil.c340
-rw-r--r--libgui/src/tkWinPrintCanvas.c14
-rw-r--r--libgui/src/tkWinPrintText.c17
21 files changed, 4569 insertions, 62 deletions
diff --git a/libgui/src/Makefile.in b/libgui/src/Makefile.in
index 637fa24f5d8..63e73211fdc 100644
--- a/libgui/src/Makefile.in
+++ b/libgui/src/Makefile.in
@@ -60,6 +60,7 @@ PRE_UNINSTALL = :
POST_UNINSTALL = :
host_alias = @host_alias@
host_triplet = @host@
+AR = @AR@
BFDHDIR = @BFDHDIR@
BFDLIB = @BFDLIB@
CC = @CC@
@@ -85,7 +86,6 @@ ITCLLIB = @ITCLLIB@
ITCLMKIDX = @ITCLMKIDX@
ITCLSH = @ITCLSH@
ITCL_BUILD_LIB_SPEC = @ITCL_BUILD_LIB_SPEC@
-ITCL_DIR = @ITCL_DIR@
ITCL_LIB_FILE = @ITCL_LIB_FILE@
ITCL_LIB_FULL_PATH = @ITCL_LIB_FULL_PATH@
ITCL_SH = @ITCL_SH@
@@ -110,6 +110,7 @@ SIMHDIR = @SIMHDIR@
SIMLIB = @SIMLIB@
TCLCONFIG = @TCLCONFIG@
TCLHDIR = @TCLHDIR@
+TCL_BIN_DIR = @TCL_BIN_DIR@
TCL_BUILD_LIB_SPEC = @TCL_BUILD_LIB_SPEC@
TCL_CFLAGS = @TCL_CFLAGS@
TCL_DEFS = @TCL_DEFS@
@@ -145,8 +146,7 @@ AUTOMAKE_OPTIONS = cygnus
noinst_LIBRARIES = libgui.a
-@INSTALL_LIBGUI_TRUE@include_HEADERS = \
-@INSTALL_LIBGUI_TRUE@\
+@INSTALL_LIBGUI_TRUE@include_HEADERS = @INSTALL_LIBGUI_TRUE@\
@INSTALL_LIBGUI_TRUE@ guitcl.h subcommand.h
TBL_VERSION = 2.1
@@ -198,7 +198,6 @@ tclwinpath.$(OBJEXT) tclmsgbox.$(OBJEXT) tclcursor.$(OBJEXT) \
tkTable.$(OBJEXT) tkTableCmd.$(OBJEXT) tkTableCell.$(OBJEXT) \
tkTableTag.$(OBJEXT) tkTableWin.$(OBJEXT) tkWinPrintText.$(OBJEXT) \
tkWinPrintCanvas.$(OBJEXT) tkWarpPointer.$(OBJEXT)
-AR = ar
CFLAGS = @CFLAGS@
COMPILE = $(CC) $(DEFS) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS)
CCLD = $(CC)
@@ -210,7 +209,7 @@ DIST_COMMON = Makefile.am Makefile.in
DISTFILES = $(DIST_COMMON) $(SOURCES) $(HEADERS) $(TEXINFOS) $(EXTRA_DIST)
-TAR = tar
+TAR = gtar
GZIP_ENV = --best
SOURCES = $(libgui_a_SOURCES)
OBJECTS = $(libgui_a_OBJECTS)
diff --git a/libgui/src/subcommand.c b/libgui/src/subcommand.c
index 29e7ea12f18..2ec51d339e6 100644
--- a/libgui/src/subcommand.c
+++ b/libgui/src/subcommand.c
@@ -26,7 +26,7 @@ subcommand_deleted (ClientData cd)
if (data->delete)
(*data->delete) (data->subdata);
- Tcl_Free ((char *) data);
+ ckfree ((char *) data);
}
/* This function implements any Tcl command registered as having
@@ -113,7 +113,7 @@ ide_create_command_with_subcommands (Tcl_Interp *interp, char *name,
}
}
- data = (struct subcommand_clientdata *) Tcl_Alloc (sizeof *data);
+ data = (struct subcommand_clientdata *) ckalloc (sizeof *data);
data->commands = table;
data->subdata = subdata;
data->delete = delete;
diff --git a/libgui/src/tclgetdir.c b/libgui/src/tclgetdir.c
index 7d70aef0012..f3b662f0dec 100644
--- a/libgui/src/tclgetdir.c
+++ b/libgui/src/tclgetdir.c
@@ -237,7 +237,7 @@ get_directory_command (ClientData cd, Tcl_Interp *interp, int argc,
re-eval. This is a lot less efficient, but it doesn't really
matter. */
- new_args = (char **) Tcl_Alloc ((argc + 2) * sizeof (char *));
+ new_args = (char **) ckalloc ((argc + 2) * sizeof (char *));
new_args[0] = "tk_getOpenFile";
new_args[1] = "-choosedir";
@@ -249,8 +249,8 @@ get_directory_command (ClientData cd, Tcl_Interp *interp, int argc,
merge = Tcl_Merge (argc + 2, new_args);
result = Tcl_GlobalEval (interp, merge);
- Tcl_Free (merge);
- Tcl_Free ((char *) new_args);
+ ckfree (merge);
+ ckfree ((char *) new_args);
return result;
}
diff --git a/libgui/src/tclhelp.c b/libgui/src/tclhelp.c
index 199cff77d2e..d3f057a145e 100644
--- a/libgui/src/tclhelp.c
+++ b/libgui/src/tclhelp.c
@@ -109,12 +109,12 @@ help_command_deleted (ClientData cd)
Tcl_DeleteExitHandler (help_command_atexit, cd);
if (hdata->filename != NULL)
- free (hdata->filename);
+ ckfree (hdata->filename);
if (hdata->header_filename != NULL)
- free (hdata->header_filename);
+ ckfree (hdata->header_filename);
if (hdata->hash_initialized)
Tcl_DeleteHashTable (&hdata->topic_hash);
- Tcl_Free ((char *) hdata);
+ ckfree ((char *) hdata);
}
/* Initialize the help system: choose a window, and set up the topic
@@ -223,8 +223,10 @@ help_initialize_command (ClientData cd, Tcl_Interp *interp, int argc,
{
struct help_command_data *hdata = (struct help_command_data *) cd;
- hdata->filename = strdup (argv[2]);
- hdata->header_filename = strdup (argv[3]);
+ hdata->filename = ckalloc (strlen (argv[2]) + 1);
+ strcpy (hdata->filename, argv[2]);
+ hdata->header_filename = ckalloc (strlen (argv[3]) + 1);
+ strcpy (hdata->header_filename, argv[3]);
return TCL_OK;
}
@@ -301,7 +303,8 @@ help_display_file_command (ClientData cd, Tcl_Interp *interp, int argc, char **a
{
struct help_command_data *hdata = (struct help_command_data *) cd;
FILE *e;
- DWORD topic_id = 0; /* default topic id is 0 which brings up the find dialog */
+ int id = 0;
+ DWORD topic_id; /* default topic id is 0 which brings up the find dialog */
/* We call Help initialize just to make sure the window handle is setup */
/* We don't care about the finding the main help file and checking the */
@@ -322,10 +325,11 @@ help_display_file_command (ClientData cd, Tcl_Interp *interp, int argc, char **a
fclose (e);
if (argc > 3)
{
- if ( Tcl_GetInt (interp, argv[3], &topic_id) != TCL_OK )
+ if ( Tcl_GetInt (interp, argv[3], &id) != TCL_OK )
return TCL_ERROR;
}
+ topic_id = (DWORD) id;
if (! WinHelp (hdata->window, argv[2], HELP_CONTEXT, topic_id))
{
char buf[200];
@@ -346,7 +350,7 @@ hdata_initialize ()
{
struct help_command_data *hdata;
- hdata = (struct help_command_data *) Tcl_Alloc (sizeof *hdata);
+ hdata = (struct help_command_data *) ckalloc (sizeof *hdata);
hdata->filename = NULL;
hdata->header_filename = NULL;
@@ -387,14 +391,16 @@ help_command_deleted (ClientData cd)
struct help_command_data *hdata = (struct help_command_data *) cd;
if (hdata->filename != NULL)
- free (hdata->filename);
+ ckfree (hdata->filename);
if (hdata->header_filename != NULL)
- free (hdata->header_filename);
+ ckfree (hdata->header_filename);
+ if (hdata->help_dir != NULL)
+ ckfree (hdata->help_dir);
if (hdata->hash_initialized)
Tcl_DeleteHashTable (&hdata->topic_hash);
if (hdata->memory_block != NULL)
- free (hdata->memory_block);
- Tcl_Free ((char *) hdata);
+ ckfree (hdata->memory_block);
+ ckfree ((char *) hdata);
}
/* Implement the ide_help initialize command. */
@@ -405,9 +411,12 @@ help_initialize_command (ClientData cd, Tcl_Interp *interp, int argc,
{
struct help_command_data *hdata = (struct help_command_data *) cd;
- hdata->filename = strdup (argv[2]);
- hdata->header_filename = strdup (argv[3]);
- hdata->help_dir = strdup (argv[4]);
+ hdata->filename = ckalloc (strlen (argv[2]) + 1);
+ strcpy (hdata->filename, argv[2]);
+ hdata->header_filename = ckalloc (strlen (argv[3]) + 1);
+ strcpy (hdata->header_filename, argv[3]);
+ hdata->help_dir = ckalloc (strlen (argv[4]) + 1);
+ strcpy (hdata->help_dir, argv[4]);
return TCL_OK;
}
@@ -427,7 +436,7 @@ help_initialize (Tcl_Interp *interp, struct help_command_data *hdata)
FILE *e;
char buf[200], *block_start;
- block_start = hdata->memory_block = malloc(6000);
+ block_start = hdata->memory_block = ckalloc(6000);
e = fopen (hdata->header_filename, "r");
if (e == NULL)
@@ -560,7 +569,7 @@ hdata_initialize ()
{
struct help_command_data *hdata;
- hdata = (struct help_command_data *) Tcl_Alloc (sizeof *hdata);
+ hdata = (struct help_command_data *) ckalloc (sizeof *hdata);
hdata->filename = NULL;
hdata->help_dir = NULL;
diff --git a/libgui/src/tclmain.c b/libgui/src/tclmain.c
index 1a962544998..28c2b8eb336 100644
--- a/libgui/src/tclmain.c
+++ b/libgui/src/tclmain.c
@@ -47,7 +47,7 @@ ide_main (int argc, char *argv[], Tcl_AppInitProc *appInitProc)
args = Tcl_Merge (argc - 1, argv + 1);
Tcl_SetVar (interp, "argv", args, TCL_GLOBAL_ONLY);
- Tcl_Free (args);
+ ckfree (args);
sprintf (buf, "%d", argc-1);
Tcl_SetVar (interp, "argc", buf, TCL_GLOBAL_ONLY);
diff --git a/libgui/src/tclmsgbox.c b/libgui/src/tclmsgbox.c
index 8db081fb2a6..918363be0ae 100644
--- a/libgui/src/tclmsgbox.c
+++ b/libgui/src/tclmsgbox.c
@@ -155,7 +155,7 @@ msgbox_wndproc (HWND hwnd, UINT message, WPARAM wparam, LPARAM lparam)
return DefWindowProc (hwnd, message, wparam, lparam);
/* Queue up a Tcl event. */
- me = (struct msgbox_event *) Tcl_Alloc (sizeof *me);
+ me = (struct msgbox_event *) ckalloc (sizeof *me);
me->header.proc = msgbox_eventproc;
me->md = (struct msgbox_data *) lparam;
Tcl_QueueEvent ((Tcl_Event *) me, TCL_QUEUE_TAIL);
@@ -202,10 +202,10 @@ msgbox_eventproc (Tcl_Event *event, int flags)
/* We are now done with the msgbox_data structure, so we can free
the fields and the structure itself. */
- Tcl_Free (me->md->code);
- Tcl_Free (me->md->message);
- Tcl_Free (me->md->title);
- Tcl_Free ((char *) me->md);
+ ckfree (me->md->code);
+ ckfree (me->md->message);
+ ckfree (me->md->title);
+ ckfree ((char *) me->md);
if (ret != TCL_OK)
Tcl_BackgroundError (me->md->interp);
@@ -401,15 +401,15 @@ msgbox_internal (ClientData clientData, Tcl_Interp *interp, int argc,
msgbox_init ();
- md = (struct msgbox_data *) Tcl_Alloc (sizeof *md);
+ md = (struct msgbox_data *) ckalloc (sizeof *md);
md->interp = interp;
- md->code = Tcl_Alloc (strlen (code) + 1);
+ md->code = ckalloc (strlen (code) + 1);
strcpy (md->code, code);
md->hidden_hwnd = hidden_hwnd;
md->hwnd = hWnd;
- md->message = Tcl_Alloc (strlen (message) + 1);
+ md->message = ckalloc (strlen (message) + 1);
strcpy (md->message, message);
- md->title = Tcl_Alloc (strlen (title) + 1);
+ md->title = ckalloc (strlen (title) + 1);
strcpy (md->title, title);
md->flags = flags | modal;
diff --git a/libgui/src/tclsizebox.c b/libgui/src/tclsizebox.c
index 9a8d30559bf..c10e2e3f9c8 100644
--- a/libgui/src/tclsizebox.c
+++ b/libgui/src/tclsizebox.c
@@ -112,7 +112,7 @@ sizebox_event_proc (ClientData cd, XEvent *event_ptr)
su = (struct sizebox_userdata *) GetWindowLong (hwnd, GWL_USERDATA);
SetWindowLong (hwnd, GWL_USERDATA, 0);
SetWindowLong (hwnd, GWL_WNDPROC, (LONG) su->wndproc);
- Tcl_Free ((char *) su);
+ ckfree ((char *) su);
DestroyWindow (hwnd);
}
}
@@ -149,7 +149,7 @@ sizebox_create (Tk_Window tkwin, Window parent, ClientData cd)
pt.x, pt.y, Tk_Width (tkwin), Tk_Height (tkwin),
parhwnd, NULL, Tk_GetHINSTANCE (), NULL);
- su = (struct sizebox_userdata *) Tcl_Alloc (sizeof *su);
+ su = (struct sizebox_userdata *) ckalloc (sizeof *su);
su->tkwin = tkwin;
su->wndproc = (WNDPROC) GetWindowLong (hwnd, GWL_WNDPROC);
SetWindowLong (hwnd, GWL_USERDATA, (LONG) su);
diff --git a/libgui/src/tclwinmode.c b/libgui/src/tclwinmode.c
index 958d5c9c607..69c6c8082ef 100644
--- a/libgui/src/tclwinmode.c
+++ b/libgui/src/tclwinmode.c
@@ -61,11 +61,11 @@ seterrormode_command (ClientData cd, Tcl_Interp *interp,
{
Tcl_AppendResult (interp, "unrecognized key \"", list[i],
"\"", (char *) NULL);
- Tcl_Free ((char *) list);
+ ckfree ((char *) list);
return TCL_ERROR;
}
}
- Tcl_Free ((char *) list);
+ ckfree ((char *) list);
val = SetErrorMode (val);
diff --git a/libgui/src/tclwinpath.c b/libgui/src/tclwinpath.c
index 2f9d5bdb612..ce75ab0dd7f 100644
--- a/libgui/src/tclwinpath.c
+++ b/libgui/src/tclwinpath.c
@@ -133,7 +133,7 @@ path_posix_to_win32_path_list (ClientData cd, Tcl_Interp *interp, int argc,
char *buf;
size = cygwin32_posix_to_win32_path_list_buf_size (argv[2]);
- buf = Tcl_Alloc (size);
+ buf = ckalloc (size);
cygwin32_posix_to_win32_path_list (argv[2], buf);
Tcl_SetResult (interp, buf, TCL_DYNAMIC);
return TCL_OK;
@@ -149,7 +149,7 @@ path_win32_to_posix_path_list (ClientData cd, Tcl_Interp *interp, int argc,
char *buf;
size = cygwin32_win32_to_posix_path_list_buf_size (argv[2]);
- buf = Tcl_Alloc (size);
+ buf = ckalloc (size);
cygwin32_win32_to_posix_path_list (argv[2], buf);
Tcl_SetResult (interp, buf, TCL_DYNAMIC);
return TCL_OK;
diff --git a/libgui/src/tclwinprint.c b/libgui/src/tclwinprint.c
index 221cc14bf77..02843493511 100644
--- a/libgui/src/tclwinprint.c
+++ b/libgui/src/tclwinprint.c
@@ -126,10 +126,10 @@ winprint_command_deleted (ClientData cd)
{
/* FIXME: I don't know if we are supposed to free the hDevMode
and hDevNames fields. */
- Tcl_Free ((char *) wd->page_setup);
+ ckfree ((char *) wd->page_setup);
}
- Tcl_Free ((char *) wd);
+ ckfree ((char *) wd);
}
/* Implement ide_winprint page_setup. */
@@ -216,7 +216,7 @@ winprint_page_setup_command (ClientData cd, Tcl_Interp *interp, int argc,
}
if (wd->page_setup == NULL)
- wd->page_setup = (PAGESETUPDLG *) Tcl_Alloc (sizeof (PAGESETUPDLG));
+ wd->page_setup = (PAGESETUPDLG *) ckalloc (sizeof (PAGESETUPDLG));
*wd->page_setup = psd;
@@ -916,7 +916,7 @@ ide_create_winprint_command (Tcl_Interp *interp)
{
struct winprint_data *wd;
- wd = (struct winprint_data *) Tcl_Alloc (sizeof *wd);
+ wd = (struct winprint_data *) ckalloc (sizeof *wd);
wd->page_setup = NULL;
wd->aborted = 0;
diff --git a/libgui/src/tkCanvEdge.c b/libgui/src/tkCanvEdge.c
index aa66702d768..a7977f0f904 100644
--- a/libgui/src/tkCanvEdge.c
+++ b/libgui/src/tkCanvEdge.c
@@ -179,8 +179,14 @@ static void TranslateEdge _ANSI_ARGS_((Tk_Canvas canvas,
static Tk_CustomOption arrowShapeOption =
{ ParseArrowShape, PrintArrowShape, (ClientData) NULL};
-static Tk_CustomOption tagsOption = {Tk_CanvasTagsParseProc,
- Tk_CanvasTagsPrintProc, (ClientData) NULL};
+/*
+ * The callbacks for tagsOption are initialized in ConfigureEdge()
+ */
+
+static Tk_CustomOption tagsOption =
+{ (Tk_OptionParseProc *) NULL,
+ (Tk_OptionPrintProc *) NULL,
+ (ClientData) NULL};
static Tk_ConfigSpec configSpecs[] = {
{TK_CONFIG_UID, "-arrow", (char *) NULL, (char *) NULL,
@@ -531,6 +537,17 @@ ConfigureEdge(interp, canvas, itemPtr, argc, argv, flags)
tkwin = Tk_CanvasTkwin(canvas);
bgBorder = ((TkCanvas *) canvas)->bgBorder;
+ /*
+ * Init callbacks in tagsOption before accessing configSpecs.
+ * This init can't be done statically when using Windows gcc
+ * since these symbols are imported from the Tk dll.
+ */
+
+ if (tagsOption.parseProc == NULL) {
+ tagsOption.parseProc = Tk_CanvasTagsParseProc;
+ tagsOption.printProc = Tk_CanvasTagsPrintProc;
+ }
+
if (Tk_ConfigureWidget(interp, tkwin,
configSpecs, argc, argv,
(char *) edgePtr, flags) != TCL_OK) {
diff --git a/libgui/src/tkGraphCanvas.c b/libgui/src/tkGraphCanvas.c
index c6ed1e71eef..eff3c6d8540 100644
--- a/libgui/src/tkGraphCanvas.c
+++ b/libgui/src/tkGraphCanvas.c
@@ -259,7 +259,8 @@ GetEdgeNodes(interp,canvasPtr,i,fp,tp)
&argc, &argv) != TCL_OK) {
return TCL_ERROR;
}
- *fp = strdup(argv[4]);
+ *fp = ckalloc (strlen (argv[4]) + 1);
+ strcpy(*fp, argv[4]);
ckfree((char*)argv);
/* Read the to node id of this edge. */
Tk_ConfigureInfo(interp, canvasPtr->tkwin,
@@ -269,7 +270,8 @@ GetEdgeNodes(interp,canvasPtr,i,fp,tp)
&argc, &argv) != TCL_OK) {
return TCL_ERROR;
}
- *tp = strdup(argv[4]);
+ *tp = ckalloc(strlen (argv[4]) + 1);
+ strcpy(*tp, argv[4]);
ckfree((char*)argv);
Tcl_ResetResult(interp);
return TCL_OK;
diff --git a/libgui/src/tkTable.tcl.h b/libgui/src/tkTable.tcl.h
new file mode 100644
index 00000000000..614106e98b5
--- /dev/null
+++ b/libgui/src/tkTable.tcl.h
@@ -0,0 +1,366 @@
+"proc tkTableClipboardKeysyms {copy cut paste} {\n"
+" bind Table <$copy> {tk_tableCopy %W}\n"
+" bind Table <$cut> {tk_tableCut %W}\n"
+" bind Table <$paste> {tk_tablePaste %W}\n"
+"}\n"
+"bind Table <3> {\n"
+" ## You might want to check for row returned if you want to\n"
+" ## restrict the resizing of certain rows\n"
+" %W border mark %x %y\n"
+"}\n"
+"bind Table <B3-Motion> { %W border dragto %x %y }\n"
+"bind Table <1> {\n"
+" if {[winfo exists %W]} {\n"
+" tkTableBeginSelect %W [%W index @%x,%y]\n"
+" focus %W\n"
+" }\n"
+"}\n"
+"bind Table <B1-Motion> {\n"
+" array set tkPriv {x %x y %y}\n"
+" tkTableMotion %W [%W index @%x,%y]\n"
+"}\n"
+"bind Table <Double-1> {\n"
+" # empty\n"
+"}\n"
+"bind Table <ButtonRelease-1> {\n"
+" if {[winfo exists %W]} {\n"
+" tkCancelRepeat\n"
+" %W activate @%x,%y\n"
+" }\n"
+"}\n"
+"bind Table <Shift-1> {tkTableBeginExtend %W [%W index @%x,%y]}\n"
+"bind Table <Control-1> {tkTableBeginToggle %W [%W index @%x,%y]}\n"
+"bind Table <B1-Enter> {tkCancelRepeat}\n"
+"bind Table <B1-Leave> {\n"
+" array set tkPriv {x %x y %y}\n"
+" tkTableAutoScan %W\n"
+"}\n"
+"bind Table <2> {\n"
+" %W scan mark %x %y\n"
+" array set tkPriv {x %x y %y}\n"
+" set tkPriv(mouseMoved) 0\n"
+"}\n"
+"bind Table <B2-Motion> {\n"
+" if {(%x != $tkPriv(x)) || (%y != $tkPriv(y))} { set tkPriv(mouseMoved) 1 }\n"
+" if $tkPriv(mouseMoved) { %W scan dragto %x %y }\n"
+"}\n"
+"bind Table <ButtonRelease-2> {\n"
+" if {!$tkPriv(mouseMoved)} { tk_tablePaste %W [%W index @%x,%y] }\n"
+"}\n"
+"if {[string comp {} [info command event]]} {\n"
+" tkTableClipboardKeysyms <Copy> <Cut> <Paste>\n"
+"} else {\n"
+" tkTableClipboardKeysyms Control-c Control-x Control-v\n"
+"}\n"
+"bind Table <Any-Tab> {\n"
+" # empty to allow Tk focus movement\n"
+"}\n"
+"bind Table <FocusOut> {\n"
+" catch {%W activate active}\n"
+"}\n"
+"bind Table <Shift-Up> {tkTableExtendSelect %W -1 0}\n"
+"bind Table <Shift-Down> {tkTableExtendSelect %W 1 0}\n"
+"bind Table <Shift-Left> {tkTableExtendSelect %W 0 -1}\n"
+"bind Table <Shift-Right> {tkTableExtendSelect %W 0 1}\n"
+"bind Table <Prior> {%W yview scroll -1 pages; %W activate @0,0}\n"
+"bind Table <Next> {%W yview scroll 1 pages; %W activate @0,0}\n"
+"bind Table <Control-Prior> {%W xview scroll -1 pages}\n"
+"bind Table <Control-Next> {%W xview scroll 1 pages}\n"
+"bind Table <Home> {%W see origin}\n"
+"bind Table <End> {%W see end}\n"
+"bind Table <Control-Home> {\n"
+" %W selection clear all\n"
+" %W activate origin\n"
+" %W selection set active\n"
+" %W see active\n"
+"}\n"
+"bind Table <Control-End> {\n"
+" %W selection clear all\n"
+" %W activate end\n"
+" %W selection set active\n"
+" %W see active\n"
+"}\n"
+"bind Table <Shift-Control-Home> {tkTableDataExtend %W origin}\n"
+"bind Table <Shift-Control-End> {tkTableDataExtend %W end}\n"
+"bind Table <Select> {tkTableBeginSelect %W [%W index active]}\n"
+"bind Table <Shift-Select> {tkTableBeginExtend %W [%W index active]}\n"
+"bind Table <Control-slash> {tkTableSelectAll %W}\n"
+"bind Table <Control-backslash> {\n"
+" if {[string match browse [%W cget -selectmode]]} {%W selection clear all}\n"
+"}\n"
+"bind Table <Up> {tkTableMoveCell %W -1 0}\n"
+"bind Table <Down> {tkTableMoveCell %W 1 0}\n"
+"bind Table <Left> {tkTableMoveCell %W 0 -1}\n"
+"bind Table <Right> {tkTableMoveCell %W 0 1}\n"
+"bind Table <Any-KeyPress> {\n"
+" if {[string compare {} %A]} { %W insert active insert %A }\n"
+"}\n"
+"bind Table <BackSpace> {\n"
+" set tkPriv(junk) [%W icursor]\n"
+" if {[string compare {} $tkPriv(junk)] && $tkPriv(junk)} {\n"
+" %W delete active [expr {$tkPriv(junk)-1}]\n"
+" }\n"
+"}\n"
+"bind Table <Delete> {%W delete active insert}\n"
+"bind Table <Escape> {%W reread}\n"
+"bind Table <Return> {\n"
+" %W insert active insert \"\n\"\n"
+"}\n"
+"bind Table <Control-Left> {%W icursor [expr {[%W icursor]-1}]}\n"
+"bind Table <Control-Right> {%W icursor [expr {[%W icursor]+1}]}\n"
+"bind Table <Control-e> {%W icursor end}\n"
+"bind Table <Control-a> {%W icursor 0}\n"
+"bind Table <Control-k> {%W delete active insert end}\n"
+"bind Table <Control-equal> {tkTableChangeWidth %W active 1}\n"
+"bind Table <Control-minus> {tkTableChangeWidth %W active -1}\n"
+"proc tkTableBeginSelect {w el} {\n"
+" global tkPriv\n"
+" if {[scan $el %d,%d r c] != 2} return\n"
+" switch [$w cget -selectmode] {\n"
+" multiple {\n"
+" if {[$w tag includes title $el]} {\n"
+" ## in the title area\n"
+" if {$r < [$w cget -titlerows]+[$w cget -roworigin]} {\n"
+" ## We're in a column header\n"
+" if {$c < [$w cget -titlecols]+[$w cget -colorigin]} {\n"
+" ## We're in the topleft title area\n"
+" set inc topleft\n"
+" set el2 end\n"
+" } else {\n"
+" set inc [$w index topleft row],$c\n"
+" set el2 [$w index end row],$c\n"
+" }\n"
+" } else {\n"
+" ## We're in a row header\n"
+" set inc $r,[$w index topleft col]\n"
+" set el2 $r,[$w index end col]\n"
+" }\n"
+" } else {\n"
+" set inc $el\n"
+" set el2 $el\n"
+" }\n"
+" if [$w selection includes $inc] {\n"
+" $w selection clear $el $el2\n"
+" } else {\n"
+" $w selection set $el $el2\n"
+" }\n"
+" }\n"
+" extended {\n"
+" $w selection clear all\n"
+" if {[$w tag includes title $el]} {\n"
+" if {$r < [$w cget -titlerows]+[$w cget -roworigin]} {\n"
+" ## We're in a column header\n"
+" if {$c < [$w cget -titlecols]+[$w cget -colorigin]} {\n"
+" $w selection set origin end\n"
+" } else {\n"
+" $w selection set $el [$w index end row],$c\n"
+" }\n"
+" } else {\n"
+" ## We're in a row header\n"
+" $w selection set $el $r,[$w index end col]\n"
+" }\n"
+" } else {\n"
+" $w selection set $el\n"
+" }\n"
+" $w selection anchor $el\n"
+" set tkPriv(tablePrev) $el\n"
+" }\n"
+" default {\n"
+" if {![$w tag includes title $el]} {\n"
+" $w selection clear all\n"
+" $w selection set $el\n"
+" set tkPriv(tablePrev) $el\n"
+" }\n"
+" $w selection anchor $el\n"
+" }\n"
+" }\n"
+"}\n"
+"proc tkTableMotion {w el} {\n"
+" global tkPriv\n"
+" if {![info exists tkPriv(tablePrev)]} {\n"
+" set tkPriv(tablePrev) $el\n"
+" return\n"
+" }\n"
+" if {[string match $tkPriv(tablePrev) $el]} return\n"
+" switch [$w cget -selectmode] {\n"
+" browse {\n"
+" $w selection clear all\n"
+" $w selection set $el\n"
+" set tkPriv(tablePrev) $el\n"
+" }\n"
+" extended {\n"
+" scan $tkPriv(tablePrev) %d,%d r c\n"
+" scan $el %d,%d elr elc\n"
+" if {[$w tag includes title $el]} {\n"
+" if {$r < [$w cget -titlerows]+[$w cget -roworigin]} {\n"
+" ## We're in a column header\n"
+" if {$c < [$w cget -titlecols]+[$w cget -colorigin]} {\n"
+" ## We're in the topleft title area\n"
+" $w selection clear anchor end\n"
+" } else {\n"
+" $w selection clear anchor [$w index end row],$c\n"
+" }\n"
+" $w selection set anchor [$w index end row],$elc\n"
+" } else {\n"
+" ## We're in a row header\n"
+" $w selection clear anchor $r,[$w index end col]\n"
+" $w selection set anchor $elr,[$w index end col]\n"
+" }\n"
+" } else {\n"
+" $w selection clear anchor $tkPriv(tablePrev)\n"
+" $w selection set anchor $el\n"
+" }\n"
+" set tkPriv(tablePrev) $el\n"
+" }\n"
+" }\n"
+"}\n"
+"proc tkTableBeginExtend {w el} {\n"
+" if {[string match extended [$w cget -selectmode]] &&\n"
+" [$w selection includes anchor]} {\n"
+" tkTableMotion $w $el\n"
+" }\n"
+"}\n"
+"proc tkTableBeginToggle {w el} {\n"
+" global tkPriv\n"
+" if {[string match extended [$w cget -selectmode]]} {\n"
+" set tkPriv(tablePrev) $el\n"
+" $w selection anchor $el\n"
+" if [$w selection includes $el] {\n"
+" $w selection clear $el\n"
+" } else {\n"
+" $w selection set $el\n"
+" }\n"
+" }\n"
+"}\n"
+"proc tkTableAutoScan {w} {\n"
+" global tkPriv\n"
+" if {![winfo exists $w]} return\n"
+" set x $tkPriv(x)\n"
+" set y $tkPriv(y)\n"
+" if {$y >= [winfo height $w]} {\n"
+" $w yview scroll 1 units\n"
+" } elseif {$y < 0} {\n"
+" $w yview scroll -1 units\n"
+" } elseif {$x >= [winfo width $w]} {\n"
+" $w xview scroll 1 units\n"
+" } elseif {$x < 0} {\n"
+" $w xview scroll -1 units\n"
+" } else {\n"
+" return\n"
+" }\n"
+" tkTableMotion $w [$w index @$x,$y]\n"
+" set tkPriv(afterId) [after 50 tkTableAutoScan $w]\n"
+"}\n"
+"proc tkTableMoveCell {w x y} {\n"
+" global tkPriv\n"
+" if {[catch {$w index active row} r]} return\n"
+" set c [$w index active col]\n"
+" $w activate [incr r $x],[incr c $y]\n"
+" $w see active\n"
+" switch [$w cget -selectmode] {\n"
+" browse {\n"
+" $w selection clear all\n"
+" $w selection set active\n"
+" }\n"
+" extended {\n"
+" $w selection clear all\n"
+" $w selection set active\n"
+" $w selection anchor active\n"
+" set tkPriv(tablePrev) [$w index active]\n"
+" }\n"
+" }\n"
+"}\n"
+"proc tkTableExtendSelect {w x y} {\n"
+" if {[string compare extended [$w cget -selectmode]] ||\n"
+" [catch {$w index active row} r]} return\n"
+" set c [$w index active col]\n"
+" $w activate [incr r $x],[incr c $y]\n"
+" $w see active\n"
+" tkTableMotion $w [$w index active]\n"
+"}\n"
+"proc tkTableDataExtend {w el} {\n"
+" set mode [$w cget -selectmode]\n"
+" if {[string match extended $mode]} {\n"
+" $w activate $el\n"
+" $w see $el\n"
+" if [$w selection includes anchor] {tkTableMotion $w $el}\n"
+" } elseif {[string match multiple $mode]} {\n"
+" $w activate $el\n"
+" $w see $el\n"
+" }\n"
+"}\n"
+"proc tkTableSelectAll {w} {\n"
+" if {[regexp {^(single|browse)$} [$w cget -selectmode]]} {\n"
+" $w selection clear all\n"
+" $w selection set active\n"
+" tkTableHandleType $w [$w index active]\n"
+" } else {\n"
+" $w selection set origin end\n"
+" }\n"
+"}\n"
+"proc tkTableChangeWidth {w i a} {\n"
+" set tmp [$w index $i col]\n"
+" if {[set width [$w width $tmp]] >= 0} {\n"
+" $w width $tmp [incr width $a]\n"
+" } else {\n"
+" $w width $tmp [incr width -$a]\n"
+" }\n"
+"}\n"
+"proc tk_tableCopy w {\n"
+" if {[selection own -displayof $w] == \"$w\"} {\n"
+" clipboard clear -displayof $w\n"
+" catch {clipboard append -displayof $w [selection get -displayof $w]}\n"
+" }\n"
+"}\n"
+"proc tk_tableCut w {\n"
+" if {[selection own -displayof $w] == \"$w\"} {\n"
+" clipboard clear -displayof $w\n"
+" catch {\n"
+" clipboard append -displayof $w [selection get -displayof $w]\n"
+" $w cursel set {}\n"
+" $w selection clear all\n"
+" }\n"
+" }\n"
+"}\n"
+"proc tk_tablePaste {w {cell {}}} {\n"
+" if {[string compare {} $cell]} {\n"
+" if {[catch {selection get -displayof $w} data]} return\n"
+" } else {\n"
+" if {[catch {selection get -displayof $w -selection CLIPBOARD} data]} {\n"
+" return\n"
+" }\n"
+" set cell active\n"
+" }\n"
+" tk_tablePasteHandler $w [$w index $cell] $data\n"
+" if {[$w cget -state] == \"normal\"} {focus $w}\n"
+"}\n"
+"proc tk_tablePasteHandler {w cell data} {\n"
+" set rows [expr {[$w cget -rows]-[$w cget -roworigin]}]\n"
+" set cols [expr {[$w cget -cols]-[$w cget -colorigin]}]\n"
+" set r [$w index $cell row]\n"
+" set c [$w index $cell col]\n"
+" set rsep [$w cget -rowseparator]\n"
+" set csep [$w cget -colseparator]\n"
+" ## Assume separate rows are split by row separator if specified\n"
+" ## If you were to want multi-character row separators, you would need:\n"
+" # regsub -all $rsep $data <newline> data\n"
+" # set data [join $data <newline>]\n"
+" if {[string comp {} $rsep]} { set data [split $data $rsep] }\n"
+" set row $r\n"
+" foreach line $data {\n"
+" if {$row > $rows} break\n"
+" set col $c\n"
+" ## Assume separate cols are split by col separator if specified\n"
+" ## Unless a -separator was specified\n"
+" if {[string comp {} $csep]} { set line [split $line $csep] }\n"
+" ## If you were to want multi-character col separators, you would need:\n"
+" # regsub -all $csep $line <newline> line\n"
+" # set line [join $line <newline>]\n"
+" foreach item $line {\n"
+" if {$col > $cols} break\n"
+" $w set $row,$col $item\n"
+" incr col\n"
+" }\n"
+" incr row\n"
+" }\n"
+"}\n"
diff --git a/libgui/src/tkTableCellSort.c b/libgui/src/tkTableCellSort.c
new file mode 100644
index 00000000000..7afc4d754a1
--- /dev/null
+++ b/libgui/src/tkTableCellSort.c
@@ -0,0 +1,400 @@
+/*
+ * tkTableCell.c --
+ *
+ * This module implements cell sort functions for table
+ * widgets. The MergeSort algorithm and other aux sorting
+ * functions were taken from tclCmdIL.c lsort command:
+
+ * tclCmdIL.c --
+ *
+ * This file contains the top-level command routines for most of
+ * the Tcl built-in commands whose names begin with the letters
+ * I through L. It contains only commands in the generic core
+ * (i.e. those that don't depend much upon UNIX facilities).
+ *
+ * Copyright (c) 1987-1993 The Regents of the University of California.
+ * Copyright (c) 1993-1997 Lucent Technologies.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * Copyright (c) 1998-1999 by Scriptics Corporation.
+
+ *
+ * Copyright (c) 1998-1999 Jeffrey Hobbs
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ */
+
+#include "tkTable.h"
+
+#ifndef UCHAR
+#define UCHAR(c) ((unsigned char) (c))
+#endif
+
+/*
+ * During execution of the "lsort" command, structures of the following
+ * type are used to arrange the objects being sorted into a collection
+ * of linked lists.
+ */
+
+typedef struct SortElement {
+ Tcl_Obj *objPtr; /* Object being sorted. */
+ struct SortElement *nextPtr; /* Next element in the list, or
+ * NULL for end of list. */
+} SortElement;
+
+static int TableSortCompareProc _ANSI_ARGS_((CONST VOID *first,
+ CONST VOID *second));
+static SortElement * MergeSort _ANSI_ARGS_((SortElement *headPt));
+static SortElement * MergeLists _ANSI_ARGS_((SortElement *leftPtr,
+ SortElement *rightPtr));
+static int DictionaryCompare _ANSI_ARGS_((char *left,
+ char *right));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TableSortCompareProc --
+ * This procedure is invoked by qsort to determine the proper
+ * ordering between two elements.
+ *
+ * Results:
+ * < 0 means first is "smaller" than "second", > 0 means "first"
+ * is larger than "second", and 0 means they should be treated
+ * as equal.
+ *
+ * Side effects:
+ * None, unless a user-defined comparison command does something
+ * weird.
+ *
+ *----------------------------------------------------------------------
+ */
+static int
+TableSortCompareProc(first, second)
+ CONST VOID *first, *second; /* Elements to be compared. */
+{
+ char *str1 = *((char **) first);
+ char *str2 = *((char **) second);
+
+ return DictionaryCompare(str1, str2);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TableCellSort --
+ * Sort a list of table cell elements (of form row,col)
+ *
+ * Results:
+ * Returns the sorted list of elements. Because Tcl_Merge allocs
+ * the space for result, it must later be Tcl_Free'd by caller.
+ *
+ * Side effects:
+ * Behaviour undefined for ill-formed input list of elements.
+ *
+ *----------------------------------------------------------------------
+ */
+char *
+TableCellSort(Table *tablePtr, char *str)
+{
+ int listArgc;
+ char **listArgv;
+ char *result;
+
+ if (Tcl_SplitList(tablePtr->interp, str, &listArgc, &listArgv) != TCL_OK) {
+ return str;
+ }
+ /* Thread safety: qsort is reportedly not thread-safe... */
+ qsort((VOID *) listArgv, (size_t) listArgc, sizeof (char *),
+ TableSortCompareProc);
+ result = Tcl_Merge(listArgc, listArgv);
+ ckfree((char *) listArgv);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DictionaryCompare - Not the Unicode version
+ *
+ * This function compares two strings as if they were being used in
+ * an index or card catalog. The case of alphabetic characters is
+ * ignored, except to break ties. Thus "B" comes before "b" but
+ * after "a". Also, integers embedded in the strings compare in
+ * numerical order. In other words, "x10y" comes after "x9y", not
+ * before it as it would when using strcmp().
+ *
+ * Results:
+ * A negative result means that the first element comes before the
+ * second, and a positive result means that the second element
+ * should come first. A result of zero means the two elements
+ * are equal and it doesn't matter which comes first.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+DictionaryCompare(left, right)
+ char *left, *right; /* The strings to compare */
+{
+ int diff, zeros;
+ int secondaryDiff = 0;
+
+ while (1) {
+ if (isdigit(UCHAR(*right)) && isdigit(UCHAR(*left))) {
+ /*
+ * There are decimal numbers embedded in the two
+ * strings. Compare them as numbers, rather than
+ * strings. If one number has more leading zeros than
+ * the other, the number with more leading zeros sorts
+ * later, but only as a secondary choice.
+ */
+
+ zeros = 0;
+ while ((*right == '0') && (isdigit(UCHAR(right[1])))) {
+ right++;
+ zeros--;
+ }
+ while ((*left == '0') && (isdigit(UCHAR(left[1])))) {
+ left++;
+ zeros++;
+ }
+ if (secondaryDiff == 0) {
+ secondaryDiff = zeros;
+ }
+
+ /*
+ * The code below compares the numbers in the two
+ * strings without ever converting them to integers. It
+ * does this by first comparing the lengths of the
+ * numbers and then comparing the digit values.
+ */
+
+ diff = 0;
+ while (1) {
+ if (diff == 0) {
+ diff = UCHAR(*left) - UCHAR(*right);
+ }
+ right++;
+ left++;
+ if (!isdigit(UCHAR(*right))) {
+ if (isdigit(UCHAR(*left))) {
+ return 1;
+ } else {
+ /*
+ * The two numbers have the same length. See
+ * if their values are different.
+ */
+
+ if (diff != 0) {
+ return diff;
+ }
+ break;
+ }
+ } else if (!isdigit(UCHAR(*left))) {
+ return -1;
+ }
+ }
+ continue;
+ }
+ diff = UCHAR(*left) - UCHAR(*right);
+ if (diff) {
+ if (isupper(UCHAR(*left)) && islower(UCHAR(*right))) {
+ diff = UCHAR(tolower(*left)) - UCHAR(*right);
+ if (diff) {
+ return diff;
+ } else if (secondaryDiff == 0) {
+ secondaryDiff = -1;
+ }
+ } else if (isupper(UCHAR(*right)) && islower(UCHAR(*left))) {
+ diff = UCHAR(*left) - UCHAR(tolower(UCHAR(*right)));
+ if (diff) {
+ return diff;
+ } else if (secondaryDiff == 0) {
+ secondaryDiff = 1;
+ }
+ } else {
+ return diff;
+ }
+ }
+ if (*left == 0) {
+ break;
+ }
+ left++;
+ right++;
+ }
+ if (diff == 0) {
+ diff = secondaryDiff;
+ }
+ return diff;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MergeLists -
+ *
+ * This procedure combines two sorted lists of SortElement structures
+ * into a single sorted list.
+ *
+ * Results:
+ * The unified list of SortElement structures.
+ *
+ * Side effects:
+ * None, unless a user-defined comparison command does something
+ * weird.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static SortElement *
+MergeLists(leftPtr, rightPtr)
+ SortElement *leftPtr; /* First list to be merged; may be
+ * NULL. */
+ SortElement *rightPtr; /* Second list to be merged; may be
+ * NULL. */
+{
+ SortElement *headPtr;
+ SortElement *tailPtr;
+
+ if (leftPtr == NULL) {
+ return rightPtr;
+ }
+ if (rightPtr == NULL) {
+ return leftPtr;
+ }
+ if (DictionaryCompare(Tcl_GetString(leftPtr->objPtr),
+ Tcl_GetString(rightPtr->objPtr)) > 0) {
+ tailPtr = rightPtr;
+ rightPtr = rightPtr->nextPtr;
+ } else {
+ tailPtr = leftPtr;
+ leftPtr = leftPtr->nextPtr;
+ }
+ headPtr = tailPtr;
+ while ((leftPtr != NULL) && (rightPtr != NULL)) {
+ if (DictionaryCompare(Tcl_GetString(leftPtr->objPtr),
+ Tcl_GetString(rightPtr->objPtr)) > 0) {
+ tailPtr->nextPtr = rightPtr;
+ tailPtr = rightPtr;
+ rightPtr = rightPtr->nextPtr;
+ } else {
+ tailPtr->nextPtr = leftPtr;
+ tailPtr = leftPtr;
+ leftPtr = leftPtr->nextPtr;
+ }
+ }
+ if (leftPtr != NULL) {
+ tailPtr->nextPtr = leftPtr;
+ } else {
+ tailPtr->nextPtr = rightPtr;
+ }
+ return headPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MergeSort -
+ *
+ * This procedure sorts a linked list of SortElement structures
+ * use the merge-sort algorithm.
+ *
+ * Results:
+ * A pointer to the head of the list after sorting is returned.
+ *
+ * Side effects:
+ * None, unless a user-defined comparison command does something
+ * weird.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static SortElement *
+MergeSort(headPtr)
+ SortElement *headPtr; /* First element on the list */
+{
+ /*
+ * The subList array below holds pointers to temporary lists built
+ * during the merge sort. Element i of the array holds a list of
+ * length 2**i.
+ */
+
+# define NUM_LISTS 30
+ SortElement *subList[NUM_LISTS];
+ SortElement *elementPtr;
+ int i;
+
+ for(i = 0; i < NUM_LISTS; i++){
+ subList[i] = NULL;
+ }
+ while (headPtr != NULL) {
+ elementPtr = headPtr;
+ headPtr = headPtr->nextPtr;
+ elementPtr->nextPtr = 0;
+ for (i = 0; (i < NUM_LISTS) && (subList[i] != NULL); i++){
+ elementPtr = MergeLists(subList[i], elementPtr);
+ subList[i] = NULL;
+ }
+ if (i >= NUM_LISTS) {
+ i = NUM_LISTS-1;
+ }
+ subList[i] = elementPtr;
+ }
+ elementPtr = NULL;
+ for (i = 0; i < NUM_LISTS; i++){
+ elementPtr = MergeLists(subList[i], elementPtr);
+ }
+ return elementPtr;
+}
+
+#ifndef NO_SORT_CELLS
+/*
+ *----------------------------------------------------------------------
+ *
+ * TableCellSortObj --
+ * Sorts a list of table cell elements (of form row,col) in place
+ *
+ * Results:
+ * Sorts list of elements in place.
+ *
+ * Side effects:
+ * Behaviour undefined for ill-formed input list of elements.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_Obj *
+TableCellSortObj(Tcl_Interp *interp, Tcl_Obj *listObjPtr)
+{
+ int length, i;
+ Tcl_Obj *sortedObjPtr, **listObjPtrs;
+ SortElement *elementArray;
+ SortElement *elementPtr;
+
+ if (Tcl_ListObjGetElements(interp, listObjPtr,
+ &length, &listObjPtrs) != TCL_OK) {
+ return NULL;
+ }
+ if (length <= 0) {
+ return listObjPtr;
+ }
+
+ elementArray = (SortElement *) ckalloc(length * sizeof(SortElement));
+ for (i=0; i < length; i++){
+ elementArray[i].objPtr = listObjPtrs[i];
+ elementArray[i].nextPtr = &elementArray[i+1];
+ }
+ elementArray[length-1].nextPtr = NULL;
+ elementPtr = MergeSort(elementArray);
+ sortedObjPtr = Tcl_NewObj();
+ for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr){
+ Tcl_ListObjAppendElement(NULL, sortedObjPtr, elementPtr->objPtr);
+ }
+ ckfree((char*) elementArray);
+
+ return sortedObjPtr;
+}
+#endif
diff --git a/libgui/src/tkTableCmds.c b/libgui/src/tkTableCmds.c
new file mode 100644
index 00000000000..4fc7d3b374a
--- /dev/null
+++ b/libgui/src/tkTableCmds.c
@@ -0,0 +1,1293 @@
+/*
+ * tkTableCmds.c --
+ *
+ * This module implements general commands of a table widget,
+ * based on the major/minor command structure.
+ *
+ * Copyright (c) 1998-2000 Jeffrey Hobbs
+ *
+ * See the file "license.txt" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ */
+
+#include "tkTable.h"
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_ActivateCmd --
+ * This procedure is invoked to process the activate method
+ * that corresponds to a table widget managed by this module.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+int
+Table_ActivateCmd(ClientData clientData, register Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ register Table *tablePtr = (Table *) clientData;
+ int result = TCL_OK;
+ int row, col;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "index");
+ return TCL_ERROR;
+ } else if (TableGetIndexObj(tablePtr, objv[2], &row, &col) != TCL_OK) {
+ return TCL_ERROR;
+ } else {
+ int x, y, w, dummy;
+ char buf1[INDEX_BUFSIZE], buf2[INDEX_BUFSIZE];
+
+ /* convert to valid active index in real coords */
+ row -= tablePtr->rowOffset;
+ col -= tablePtr->colOffset;
+ /* we do this regardless, to avoid cell commit problems */
+ if ((tablePtr->flags & HAS_ACTIVE) &&
+ (tablePtr->flags & TEXT_CHANGED)) {
+ tablePtr->flags &= ~TEXT_CHANGED;
+ TableSetCellValue(tablePtr,
+ tablePtr->activeRow+tablePtr->rowOffset,
+ tablePtr->activeCol+tablePtr->colOffset,
+ tablePtr->activeBuf);
+ }
+ if (row != tablePtr->activeRow || col != tablePtr->activeCol) {
+ if (tablePtr->flags & HAS_ACTIVE) {
+ TableMakeArrayIndex(tablePtr->activeRow+tablePtr->rowOffset,
+ tablePtr->activeCol+tablePtr->colOffset,
+ buf1);
+ } else {
+ buf1[0] = '\0';
+ }
+ tablePtr->flags |= HAS_ACTIVE;
+ tablePtr->flags &= ~ACTIVE_DISABLED;
+ tablePtr->activeRow = row;
+ tablePtr->activeCol = col;
+ if (tablePtr->activeTagPtr != NULL) {
+ ckfree((char *) (tablePtr->activeTagPtr));
+ tablePtr->activeTagPtr = NULL;
+ }
+ TableAdjustActive(tablePtr);
+ TableConfigCursor(tablePtr);
+ if (!(tablePtr->flags & BROWSE_CMD) &&
+ tablePtr->browseCmd != NULL) {
+ Tcl_DString script;
+ tablePtr->flags |= BROWSE_CMD;
+ row = tablePtr->activeRow+tablePtr->rowOffset;
+ col = tablePtr->activeCol+tablePtr->colOffset;
+ TableMakeArrayIndex(row, col, buf2);
+ Tcl_DStringInit(&script);
+ ExpandPercents(tablePtr, tablePtr->browseCmd, row, col,
+ buf1, buf2, tablePtr->icursor, &script, 0);
+ result = Tcl_GlobalEval(interp, Tcl_DStringValue(&script));
+ if (result == TCL_OK || result == TCL_RETURN) {
+ Tcl_ResetResult(interp);
+ }
+ Tcl_DStringFree(&script);
+ tablePtr->flags &= ~BROWSE_CMD;
+ }
+ } else {
+ char *p = Tcl_GetString(objv[2]);
+
+ if ((tablePtr->activeTagPtr != NULL) && *p == '@' &&
+ !(tablePtr->flags & ACTIVE_DISABLED) &&
+ TableCellVCoords(tablePtr, row, col, &x, &y, &w, &dummy, 0)) {
+ /* we are clicking into the same cell
+ * If it was activated with @x,y indexing,
+ * find the closest char */
+ Tk_TextLayout textLayout;
+ TableTag *tagPtr = tablePtr->activeTagPtr;
+
+ /* no error checking because GetIndex did it for us */
+ p++;
+ x = strtol(p, &p, 0) - x - tablePtr->activeX;
+ y = strtol(++p, &p, 0) - y - tablePtr->activeY;
+
+ textLayout = Tk_ComputeTextLayout(tagPtr->tkfont,
+ tablePtr->activeBuf, -1,
+ (tagPtr->wrap) ? w : 0,
+ tagPtr->justify, 0, &dummy, &dummy);
+
+ tablePtr->icursor = Tk_PointToChar(textLayout, x, y);
+ Tk_FreeTextLayout(textLayout);
+ TableRefresh(tablePtr, row, col, CELL|INV_FORCE);
+ }
+ }
+ tablePtr->flags |= HAS_ACTIVE;
+ }
+ return result;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_AdjustCmd --
+ * This procedure is invoked to process the width/height method
+ * that corresponds to a table widget managed by this module.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+int
+Table_AdjustCmd(ClientData clientData, register Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ register Table *tablePtr = (Table *) clientData;
+ Tcl_HashEntry *entryPtr;
+ Tcl_HashSearch search;
+ Tcl_HashTable *hashTablePtr;
+ int i, widthType, dummy, value, posn, offset;
+ char buf1[INDEX_BUFSIZE];
+
+ widthType = (*(Tcl_GetString(objv[1])) == 'w');
+ /* changes the width/height of certain selected columns */
+ if (objc != 3 && (objc & 1)) {
+ Tcl_WrongNumArgs(interp, 2, objv, widthType ?
+ "?col? ?width col width ...?" :
+ "?row? ?height row height ...?");
+ return TCL_ERROR;
+ }
+ if (widthType) {
+ hashTablePtr = tablePtr->colWidths;
+ offset = tablePtr->colOffset;
+ } else {
+ hashTablePtr = tablePtr->rowHeights;
+ offset = tablePtr->rowOffset;
+ }
+
+ if (objc == 2) {
+ /* print out all the preset column widths or row heights */
+ entryPtr = Tcl_FirstHashEntry(hashTablePtr, &search);
+ while (entryPtr != NULL) {
+ posn = ((int) Tcl_GetHashKey(hashTablePtr, entryPtr)) + offset;
+ value = (int) Tcl_GetHashValue(entryPtr);
+ sprintf(buf1, "%d %d", posn, value);
+ /* OBJECTIFY */
+ Tcl_AppendElement(interp, buf1);
+ entryPtr = Tcl_NextHashEntry(&search);
+ }
+ } else if (objc == 3) {
+ /* get the width/height of a particular row/col */
+ if (Tcl_GetIntFromObj(interp, objv[2], &posn) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ /* no range check is done, why bother? */
+ posn -= offset;
+ entryPtr = Tcl_FindHashEntry(hashTablePtr, (char *) posn);
+ if (entryPtr != NULL) {
+ Tcl_SetIntObj(Tcl_GetObjResult(interp),
+ (int) Tcl_GetHashValue(entryPtr));
+ } else {
+ Tcl_SetIntObj(Tcl_GetObjResult(interp), widthType ?
+ tablePtr->defColWidth : tablePtr->defRowHeight);
+ }
+ } else {
+ for (i=2; i<objc; i++) {
+ /* set new width|height here */
+ value = -999999;
+ if (Tcl_GetIntFromObj(interp, objv[i++], &posn) != TCL_OK ||
+ (strcmp(Tcl_GetString(objv[i]), "default") &&
+ Tcl_GetIntFromObj(interp, objv[i], &value) != TCL_OK)) {
+ return TCL_ERROR;
+ }
+ posn -= offset;
+ if (value == -999999) {
+ /* reset that field */
+ entryPtr = Tcl_FindHashEntry(hashTablePtr, (char *) posn);
+ if (entryPtr != NULL) {
+ Tcl_DeleteHashEntry(entryPtr);
+ }
+ } else {
+ entryPtr = Tcl_CreateHashEntry(hashTablePtr,
+ (char *) posn, &dummy);
+ Tcl_SetHashValue(entryPtr, (ClientData) value);
+ }
+ }
+ TableAdjustParams(tablePtr);
+ /* rerequest geometry */
+ TableGeometryRequest(tablePtr);
+ /*
+ * Invalidate the whole window as TableAdjustParams
+ * will only check to see if the top left cell has moved
+ * FIX: should just move from lowest order visible cell
+ * to edge of window
+ */
+ TableInvalidateAll(tablePtr, 0);
+ }
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_BboxCmd --
+ * This procedure is invoked to process the bbox method
+ * that corresponds to a table widget managed by this module.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+int
+Table_BboxCmd(ClientData clientData, register Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ register Table *tablePtr = (Table *) clientData;
+ int x, y, w, h, row, col, key;
+ Tcl_Obj *resultPtr;
+
+ /* Returns bounding box of cell(s) */
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "first ?last?");
+ return TCL_ERROR;
+ } else if (TableGetIndexObj(tablePtr, objv[2], &row, &col) == TCL_ERROR ||
+ (objc == 4 &&
+ TableGetIndexObj(tablePtr, objv[3], &x, &y) == TCL_ERROR)) {
+ return TCL_ERROR;
+ }
+
+ resultPtr = Tcl_GetObjResult(interp);
+ if (objc == 3) {
+ row -= tablePtr->rowOffset; col -= tablePtr->colOffset;
+ if (TableCellVCoords(tablePtr, row, col, &x, &y, &w, &h, 0)) {
+ Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewIntObj(x));
+ Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewIntObj(y));
+ Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewIntObj(w));
+ Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewIntObj(h));
+ }
+ return TCL_OK;
+ } else {
+ int r1, c1, r2, c2, minX = 99999, minY = 99999, maxX = 0, maxY = 0;
+
+ row -= tablePtr->rowOffset; col -= tablePtr->colOffset;
+ x -= tablePtr->rowOffset; y -= tablePtr->colOffset;
+ r1 = MIN(row,x); r2 = MAX(row,x);
+ c1 = MIN(col,y); c2 = MAX(col,y);
+ key = 0;
+ for (row = r1; row <= r2; row++) {
+ for (col = c1; col <= c2; col++) {
+ if (TableCellVCoords(tablePtr, row, col, &x, &y, &w, &h, 0)) {
+ /* Get max bounding box */
+ if (x < minX) minX = x;
+ if (y < minY) minY = y;
+ if (x+w > maxX) maxX = x+w;
+ if (y+h > maxY) maxY = y+h;
+ key++;
+ }
+ }
+ }
+ if (key) {
+ Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewIntObj(minX));
+ Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewIntObj(minY));
+ Tcl_ListObjAppendElement(NULL, resultPtr,
+ Tcl_NewIntObj(maxX-minX));
+ Tcl_ListObjAppendElement(NULL, resultPtr,
+ Tcl_NewIntObj(maxY-minY));
+ }
+ }
+ return TCL_OK;
+}
+
+static char *bdCmdNames[] = {
+ "mark", "dragto", (char *)NULL
+};
+enum bdCmd {
+ BD_MARK, BD_DRAGTO
+};
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_BorderCmd --
+ * This procedure is invoked to process the bbox method
+ * that corresponds to a table widget managed by this module.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+int
+Table_BorderCmd(ClientData clientData, register Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ register Table *tablePtr = (Table *) clientData;
+ Tcl_HashEntry *entryPtr;
+ int x, y, w, h, row, col, key, dummy, value, cmdIndex;
+ char *rc = NULL;
+ Tcl_Obj *objPtr, *resultPtr;
+
+ if (objc < 5 || objc > 6) {
+ Tcl_WrongNumArgs(interp, 2, objv, "mark|dragto x y ?row|col?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[2], bdCmdNames,
+ "option", 0, &cmdIndex) != TCL_OK ||
+ Tcl_GetIntFromObj(interp, objv[3], &x) != TCL_OK ||
+ Tcl_GetIntFromObj(interp, objv[4], &y) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc == 6) {
+ rc = Tcl_GetStringFromObj(objv[5], &w);
+ if ((w < 1) || (strncmp(rc, "row", w) && strncmp(rc, "col", w))) {
+ Tcl_WrongNumArgs(interp, 2, objv, "mark|dragto x y ?row|col?");
+ return TCL_ERROR;
+ }
+ }
+
+ resultPtr = Tcl_GetObjResult(interp);
+ switch ((enum bdCmd) cmdIndex) {
+ case BD_MARK:
+ /* Use x && y to determine if we are over a border */
+ value = TableAtBorder(tablePtr, x, y, &row, &col);
+ /* Cache the row && col for use in DRAGTO */
+ tablePtr->scanMarkRow = row;
+ tablePtr->scanMarkCol = col;
+ if (!value) {
+ return TCL_OK;
+ }
+ TableCellCoords(tablePtr, row, col, &x, &y, &dummy, &dummy);
+ tablePtr->scanMarkX = x;
+ tablePtr->scanMarkY = y;
+ if (objc == 5 || *rc == 'r') {
+ if (row < 0) {
+ objPtr = Tcl_NewStringObj("", 0);
+ } else {
+ objPtr = Tcl_NewIntObj(row+tablePtr->rowOffset);
+ }
+ Tcl_ListObjAppendElement(NULL, resultPtr, objPtr);
+ }
+ if (objc == 5 || *rc == 'c') {
+ if (col < 0) {
+ objPtr = Tcl_NewStringObj("", 0);
+ } else {
+ objPtr = Tcl_NewIntObj(col+tablePtr->colOffset);
+ }
+ Tcl_ListObjAppendElement(NULL, resultPtr, objPtr);
+ }
+ return TCL_OK; /* BORDER MARK */
+
+ case BD_DRAGTO:
+ /* check to see if we want to resize any borders */
+ if (tablePtr->resize == SEL_NONE) { return TCL_OK; }
+ row = tablePtr->scanMarkRow;
+ col = tablePtr->scanMarkCol;
+ TableCellCoords(tablePtr, row, col, &w, &h, &dummy, &dummy);
+ key = 0;
+ if (row >= 0 && (tablePtr->resize & SEL_ROW)) {
+ /* row border was active, move it */
+ value = y-h;
+ if (value < -1) value = -1;
+ if (value != tablePtr->scanMarkY) {
+ entryPtr = Tcl_CreateHashEntry(tablePtr->rowHeights,
+ (char *) row, &dummy);
+ /* -value means rowHeight will be interp'd as pixels, not
+ lines */
+ Tcl_SetHashValue(entryPtr, (ClientData) MIN(0,-value));
+ tablePtr->scanMarkY = value;
+ key++;
+ }
+ }
+ if (col >= 0 && (tablePtr->resize & SEL_COL)) {
+ /* col border was active, move it */
+ value = x-w;
+ if (value < -1) value = -1;
+ if (value != tablePtr->scanMarkX) {
+ entryPtr = Tcl_CreateHashEntry(tablePtr->colWidths,
+ (char *) col, &dummy);
+ /* -value means colWidth will be interp'd as pixels, not
+ chars */
+ Tcl_SetHashValue(entryPtr, (ClientData) MIN(0,-value));
+ tablePtr->scanMarkX = value;
+ key++;
+ }
+ }
+ /* Only if something changed do we want to update */
+ if (key) {
+ TableAdjustParams(tablePtr);
+ /* Only rerequest geometry if the basis is the #rows &| #cols */
+ if (tablePtr->maxReqCols || tablePtr->maxReqRows)
+ TableGeometryRequest(tablePtr);
+ TableInvalidateAll(tablePtr, 0);
+ }
+ return TCL_OK; /* BORDER DRAGTO */
+ }
+ return TCL_OK;
+}
+
+/* clear subcommands */
+static char *clearNames[] = {
+ "all", "cache", "sizes", "tags", (char *)NULL
+};
+enum clearCommand {
+ CLEAR_ALL, CLEAR_CACHE, CLEAR_SIZES, CLEAR_TAGS
+};
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_ClearCmd --
+ * This procedure is invoked to process the clear method
+ * that corresponds to a table widget managed by this module.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * Cached info can be lost. Returns valid Tcl result.
+ *
+ * Side effects:
+ * Can cause redraw.
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+int
+Table_ClearCmd(ClientData clientData, register Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ register Table *tablePtr = (Table *) clientData;
+ int cmdIndex, redraw = 0;
+
+ if (objc < 3 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "option ?first? ?last?");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetIndexFromObj(interp, objv[2], clearNames,
+ "clear option", 0, &cmdIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (objc == 3) {
+ if (cmdIndex == CLEAR_TAGS || cmdIndex == CLEAR_ALL) {
+ Tcl_DeleteHashTable(tablePtr->rowStyles);
+ Tcl_DeleteHashTable(tablePtr->colStyles);
+ Tcl_DeleteHashTable(tablePtr->cellStyles);
+ Tcl_DeleteHashTable(tablePtr->flashCells);
+ Tcl_DeleteHashTable(tablePtr->selCells);
+
+ /* style hash tables */
+ Tcl_InitHashTable(tablePtr->rowStyles, TCL_ONE_WORD_KEYS);
+ Tcl_InitHashTable(tablePtr->colStyles, TCL_ONE_WORD_KEYS);
+ Tcl_InitHashTable(tablePtr->cellStyles, TCL_STRING_KEYS);
+
+ /* special style hash tables */
+ Tcl_InitHashTable(tablePtr->flashCells, TCL_STRING_KEYS);
+ Tcl_InitHashTable(tablePtr->selCells, TCL_STRING_KEYS);
+ }
+
+ if (cmdIndex == CLEAR_SIZES || cmdIndex == CLEAR_ALL) {
+ Tcl_DeleteHashTable(tablePtr->colWidths);
+ Tcl_DeleteHashTable(tablePtr->rowHeights);
+
+ /* style hash tables */
+ Tcl_InitHashTable(tablePtr->colWidths, TCL_ONE_WORD_KEYS);
+ Tcl_InitHashTable(tablePtr->rowHeights, TCL_ONE_WORD_KEYS);
+ }
+
+ if (cmdIndex == CLEAR_CACHE || cmdIndex == CLEAR_ALL) {
+ Tcl_DeleteHashTable(tablePtr->cache);
+ Tcl_InitHashTable(tablePtr->cache, TCL_STRING_KEYS);
+ /* If we were caching and we have no other data source,
+ * invalidate all the cells */
+ if (tablePtr->dataSource == DATA_CACHE) {
+ TableGetActiveBuf(tablePtr);
+ }
+ }
+ redraw = 1;
+ } else {
+ int row, col, r1, r2, c1, c2;
+ Tcl_HashEntry *entryPtr;
+ char buf[INDEX_BUFSIZE];
+
+ if (TableGetIndexObj(tablePtr, objv[3], &row, &col) != TCL_OK ||
+ ((objc == 5) &&
+ TableGetIndexObj(tablePtr, objv[4], &r2, &c2) != TCL_OK)) {
+ return TCL_ERROR;
+ }
+ if (objc == 4) {
+ r1 = r2 = row;
+ c1 = c2 = col;
+ } else {
+ r1 = MIN(row,r2); r2 = MAX(row,r2);
+ c1 = MIN(col,c2); c2 = MAX(col,c2);
+ }
+ for (row = r1; row <= r2; row++) {
+ /* Note that *Styles entries are user based (no offset)
+ * while size entries are 0-based (real) */
+ if ((cmdIndex == CLEAR_TAGS || cmdIndex == CLEAR_ALL) &&
+ (entryPtr = Tcl_FindHashEntry(tablePtr->rowStyles,
+ (char *) row))) {
+ Tcl_DeleteHashEntry(entryPtr);
+ redraw = 1;
+ }
+
+ if ((cmdIndex == CLEAR_SIZES || cmdIndex == CLEAR_ALL) &&
+ (entryPtr = Tcl_FindHashEntry(tablePtr->rowHeights,
+ (char *) row-tablePtr->rowOffset))) {
+ Tcl_DeleteHashEntry(entryPtr);
+ redraw = 1;
+ }
+
+ for (col = c1; col <= c2; col++) {
+ TableMakeArrayIndex(row, col, buf);
+
+ if (cmdIndex == CLEAR_TAGS || cmdIndex == CLEAR_ALL) {
+ if ((row == r1) &&
+ (entryPtr = Tcl_FindHashEntry(tablePtr->colStyles,
+ (char *) col))) {
+ Tcl_DeleteHashEntry(entryPtr);
+ redraw = 1;
+ }
+ if ((entryPtr = Tcl_FindHashEntry(tablePtr->cellStyles,
+ buf))) {
+ Tcl_DeleteHashEntry(entryPtr);
+ redraw = 1;
+ }
+ if ((entryPtr = Tcl_FindHashEntry(tablePtr->flashCells,
+ buf))) {
+ Tcl_DeleteHashEntry(entryPtr);
+ redraw = 1;
+ }
+ if ((entryPtr = Tcl_FindHashEntry(tablePtr->selCells,
+ buf))) {
+ Tcl_DeleteHashEntry(entryPtr);
+ redraw = 1;
+ }
+ }
+
+ if ((cmdIndex == CLEAR_SIZES || cmdIndex == CLEAR_ALL) &&
+ row == r1 &&
+ (entryPtr = Tcl_FindHashEntry(tablePtr->colWidths, (char *)
+ col-tablePtr->colOffset))) {
+ Tcl_DeleteHashEntry(entryPtr);
+ redraw = 1;
+ }
+
+ if ((cmdIndex == CLEAR_CACHE || cmdIndex == CLEAR_ALL) &&
+ (entryPtr = Tcl_FindHashEntry(tablePtr->cache, buf))) {
+ Tcl_DeleteHashEntry(entryPtr);
+ /* if the cache is our data source,
+ * we need to invalidate the cells changed */
+ if ((tablePtr->dataSource == DATA_CACHE) &&
+ (row-tablePtr->rowOffset == tablePtr->activeRow &&
+ col-tablePtr->colOffset == tablePtr->activeCol))
+ TableGetActiveBuf(tablePtr);
+ redraw = 1;
+ }
+ }
+ }
+ }
+ /* This could be more sensitive about what it updates,
+ * but that can actually be a lot more costly in some cases */
+ if (redraw) {
+ if (cmdIndex == CLEAR_SIZES || cmdIndex == CLEAR_ALL) {
+ TableAdjustParams(tablePtr);
+ /* rerequest geometry */
+ TableGeometryRequest(tablePtr);
+ }
+ TableInvalidateAll(tablePtr, 0);
+ }
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_CurselectionCmd --
+ * This procedure is invoked to process the bbox method
+ * that corresponds to a table widget managed by this module.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+int
+Table_CurselectionCmd(ClientData clientData, register Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ register Table *tablePtr = (Table *) clientData;
+ Tcl_HashEntry *entryPtr;
+ Tcl_HashSearch search;
+ char *value = NULL;
+ int row, col;
+
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?value?");
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ /* make sure there is a data source to accept a set value */
+ if ((tablePtr->state == STATE_DISABLED) ||
+ (tablePtr->dataSource == DATA_NONE)) {
+ return TCL_OK;
+ }
+ value = Tcl_GetString(objv[2]);
+ for (entryPtr = Tcl_FirstHashEntry(tablePtr->selCells, &search);
+ entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) {
+ TableParseArrayIndex(&row, &col,
+ Tcl_GetHashKey(tablePtr->selCells, entryPtr));
+ TableSetCellValue(tablePtr, row, col, value);
+ row -= tablePtr->rowOffset;
+ col -= tablePtr->colOffset;
+ if (row == tablePtr->activeRow && col == tablePtr->activeCol) {
+ TableGetActiveBuf(tablePtr);
+ }
+ TableRefresh(tablePtr, row, col, CELL);
+ }
+ } else {
+ Tcl_Obj *objPtr = Tcl_NewObj();
+
+ for (entryPtr = Tcl_FirstHashEntry(tablePtr->selCells, &search);
+ entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) {
+ value = Tcl_GetHashKey(tablePtr->selCells, entryPtr);
+ Tcl_ListObjAppendElement(NULL, objPtr,
+ Tcl_NewStringObj(value, -1));
+ }
+ Tcl_SetObjResult(interp, TableCellSortObj(interp, objPtr));
+ }
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_CurvalueCmd --
+ * This procedure is invoked to process the curvalue method
+ * that corresponds to a table widget managed by this module.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+int
+Table_CurvalueCmd(ClientData clientData, register Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ register Table *tablePtr = (Table *) clientData;
+
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?<value>?");
+ return TCL_ERROR;
+ } else if (!(tablePtr->flags & HAS_ACTIVE)) {
+ return TCL_OK;
+ }
+
+ if (objc == 3) {
+ char *value;
+ int len;
+
+ value = Tcl_GetStringFromObj(objv[2], &len);
+ if (STREQ(value, tablePtr->activeBuf)) {
+ Tcl_SetObjResult(interp, objv[2]);
+ return TCL_OK;
+ }
+ /* validate potential new active buffer contents
+ * only accept if validation returns acceptance. */
+ if (tablePtr->validate &&
+ TableValidateChange(tablePtr,
+ tablePtr->activeRow+tablePtr->rowOffset,
+ tablePtr->activeCol+tablePtr->colOffset,
+ tablePtr->activeBuf,
+ value, tablePtr->icursor) != TCL_OK) {
+ return TCL_OK;
+ }
+ tablePtr->activeBuf = (char *)ckrealloc(tablePtr->activeBuf, len+1);
+ strcpy(tablePtr->activeBuf, value);
+ /* mark the text as changed */
+ tablePtr->flags |= TEXT_CHANGED;
+ TableSetActiveIndex(tablePtr);
+ /* check for possible adjustment of icursor */
+ TableGetIcursor(tablePtr, "insert", (int *)0);
+ TableRefresh(tablePtr, tablePtr->activeRow, tablePtr->activeCol, CELL);
+ }
+
+ Tcl_SetStringObj(Tcl_GetObjResult(interp), tablePtr->activeBuf, -1);
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_GetCmd --
+ * This procedure is invoked to process the bbox method
+ * that corresponds to a table widget managed by this module.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+int
+Table_GetCmd(ClientData clientData, register Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ register Table *tablePtr = (Table *) clientData;
+ int result = TCL_OK;
+ int r1, c1, r2, c2, row, col;
+
+ if (objc < 3 || objc > 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "first ?last?");
+ result = TCL_ERROR;
+ } else if (TableGetIndexObj(tablePtr, objv[2], &row, &col) == TCL_ERROR) {
+ result = TCL_ERROR;
+ } else if (objc == 3) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(TableGetCellValue(tablePtr, row, col), -1));
+ } else if (TableGetIndexObj(tablePtr, objv[3], &r2, &c2) == TCL_ERROR) {
+ result = TCL_ERROR;
+ } else {
+ Tcl_Obj *objPtr = Tcl_NewObj();
+
+ r1 = MIN(row,r2); r2 = MAX(row,r2);
+ c1 = MIN(col,c2); c2 = MAX(col,c2);
+ for ( row = r1; row <= r2; row++ ) {
+ for ( col = c1; col <= c2; col++ ) {
+ Tcl_ListObjAppendElement(NULL, objPtr,
+ Tcl_NewStringObj(TableGetCellValue(tablePtr,
+ row, col), -1));
+ }
+ }
+ Tcl_SetObjResult(interp, objPtr);
+ }
+ return result;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_ScanCmd --
+ * This procedure is invoked to process the scan method
+ * that corresponds to a table widget managed by this module.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+int
+Table_ScanCmd(ClientData clientData, register Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ register Table *tablePtr = (Table *) clientData;
+ int x, y, row, col, cmdIndex;
+
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "mark|dragto x y");
+ return TCL_ERROR;
+ } else if (Tcl_GetIndexFromObj(interp, objv[2], bdCmdNames,
+ "option", 0, &cmdIndex) != TCL_OK ||
+ Tcl_GetIntFromObj(interp, objv[3], &x) == TCL_ERROR ||
+ Tcl_GetIntFromObj(interp, objv[4], &y) == TCL_ERROR) {
+ return TCL_ERROR;
+ }
+ switch ((enum bdCmd) cmdIndex) {
+ case BD_MARK:
+ TableWhatCell(tablePtr, x, y, &row, &col);
+ tablePtr->scanMarkRow = row-tablePtr->topRow;
+ tablePtr->scanMarkCol = col-tablePtr->leftCol;
+ tablePtr->scanMarkX = x;
+ tablePtr->scanMarkY = y;
+ break;
+
+ case BD_DRAGTO: {
+ int oldTop = tablePtr->topRow, oldLeft = tablePtr->leftCol;
+ y += (5*(y-tablePtr->scanMarkY));
+ x += (5*(x-tablePtr->scanMarkX));
+
+ TableWhatCell(tablePtr, x, y, &row, &col);
+
+ /* maintain appropriate real index */
+ tablePtr->topRow = BETWEEN(row-tablePtr->scanMarkRow,
+ tablePtr->titleRows, tablePtr->rows-1);
+ tablePtr->leftCol = BETWEEN(col-tablePtr->scanMarkCol,
+ tablePtr->titleCols, tablePtr->cols-1);
+
+ /* Adjust the table if new top left */
+ if (oldTop != tablePtr->topRow || oldLeft != tablePtr->leftCol) {
+ TableAdjustParams(tablePtr);
+ }
+ break;
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_SelAnchorCmd --
+ * This procedure is invoked to process the selection anchor method
+ * that corresponds to a table widget managed by this module.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+int
+Table_SelAnchorCmd(ClientData clientData, register Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ register Table *tablePtr = (Table *) clientData;
+ int row, col;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 3, objv, "index");
+ return TCL_ERROR;
+ } else if (TableGetIndexObj(tablePtr, objv[3], &row, &col) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ tablePtr->flags |= HAS_ANCHOR;
+ /* maintain appropriate real index */
+ if (tablePtr->selectTitles) {
+ tablePtr->anchorRow = BETWEEN(row-tablePtr->rowOffset,
+ 0, tablePtr->rows-1);
+ tablePtr->anchorCol = BETWEEN(col-tablePtr->colOffset,
+ 0, tablePtr->cols-1);
+ } else {
+ tablePtr->anchorRow = BETWEEN(row-tablePtr->rowOffset,
+ tablePtr->titleRows, tablePtr->rows-1);
+ tablePtr->anchorCol = BETWEEN(col-tablePtr->colOffset,
+ tablePtr->titleCols, tablePtr->cols-1);
+ }
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_SelClearCmd --
+ * This procedure is invoked to process the selection clear method
+ * that corresponds to a table widget managed by this module.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+int
+Table_SelClearCmd(ClientData clientData, register Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ register Table *tablePtr = (Table *) clientData;
+ int result = TCL_OK;
+ char buf1[INDEX_BUFSIZE];
+ int row, col, key, clo=0,chi=0,r1,c1,r2,c2;
+ Tcl_HashEntry *entryPtr;
+
+ if (objc < 4 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 3, objv, "all|<first> ?<last>?");
+ return TCL_ERROR;
+ }
+ if (STREQ(Tcl_GetString(objv[3]), "all")) {
+ Tcl_HashSearch search;
+ for(entryPtr = Tcl_FirstHashEntry(tablePtr->selCells, &search);
+ entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search)) {
+ TableParseArrayIndex(&row, &col,
+ Tcl_GetHashKey(tablePtr->selCells,entryPtr));
+ Tcl_DeleteHashEntry(entryPtr);
+ TableRefresh(tablePtr, row-tablePtr->rowOffset,
+ col-tablePtr->colOffset, CELL);
+ }
+ return TCL_OK;
+ }
+ if (TableGetIndexObj(tablePtr, objv[3], &row, &col) == TCL_ERROR ||
+ (objc==5 &&
+ TableGetIndexObj(tablePtr, objv[4], &r2, &c2) == TCL_ERROR)) {
+ return TCL_ERROR;
+ }
+ key = 0;
+ if (objc == 4) {
+ r1 = r2 = row;
+ c1 = c2 = col;
+ } else {
+ r1 = MIN(row,r2); r2 = MAX(row,r2);
+ c1 = MIN(col,c2); c2 = MAX(col,c2);
+ }
+ switch (tablePtr->selectType) {
+ case SEL_BOTH:
+ clo = c1; chi = c2;
+ c1 = tablePtr->colOffset;
+ c2 = tablePtr->cols-1+c1;
+ key = 1;
+ goto CLEAR_CELLS;
+ CLEAR_BOTH:
+ key = 0;
+ c1 = clo; c2 = chi;
+ case SEL_COL:
+ r1 = tablePtr->rowOffset;
+ r2 = tablePtr->rows-1+r1;
+ break;
+ case SEL_ROW:
+ c1 = tablePtr->colOffset;
+ c2 = tablePtr->cols-1+c1;
+ break;
+ }
+ /* row/col are in user index coords */
+CLEAR_CELLS:
+ for ( row = r1; row <= r2; row++ ) {
+ for ( col = c1; col <= c2; col++ ) {
+ TableMakeArrayIndex(row, col, buf1);
+ entryPtr = Tcl_FindHashEntry(tablePtr->selCells, buf1);
+ if (entryPtr != NULL) {
+ Tcl_DeleteHashEntry(entryPtr);
+ TableRefresh(tablePtr, row-tablePtr->rowOffset,
+ col-tablePtr->colOffset, CELL);
+ }
+ }
+ }
+ if (key) goto CLEAR_BOTH;
+ return result;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_SelIncludesCmd --
+ * This procedure is invoked to process the selection includes method
+ * that corresponds to a table widget managed by this module.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+int
+Table_SelIncludesCmd(ClientData clientData, register Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ register Table *tablePtr = (Table *) clientData;
+ int row, col;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 3, objv, "index");
+ return TCL_ERROR;
+ } else if (TableGetIndexObj(tablePtr, objv[3], &row, &col) == TCL_ERROR) {
+ return TCL_ERROR;
+ } else {
+ char buf[INDEX_BUFSIZE];
+ TableMakeArrayIndex(row, col, buf);
+ Tcl_SetBooleanObj(Tcl_GetObjResult(interp),
+ (Tcl_FindHashEntry(tablePtr->selCells, buf)!=NULL));
+ }
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_SelSetCmd --
+ * This procedure is invoked to process the selection set method
+ * that corresponds to a table widget managed by this module.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+int
+Table_SelSetCmd(ClientData clientData, register Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ register Table *tablePtr = (Table *) clientData;
+ int row, col, dummy, key;
+ char buf1[INDEX_BUFSIZE];
+ Tcl_HashSearch search;
+ Tcl_HashEntry *entryPtr;
+
+ int clo=0, chi=0, r1, c1, r2, c2, firstRow, firstCol, lastRow, lastCol;
+ if (objc < 4 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 3, objv, "first ?last?");
+ return TCL_ERROR;
+ }
+ if (TableGetIndexObj(tablePtr, objv[3], &row, &col) == TCL_ERROR ||
+ (objc==5 &&
+ TableGetIndexObj(tablePtr, objv[4], &r2, &c2) == TCL_ERROR)) {
+ return TCL_ERROR;
+ }
+ key = 0;
+ lastRow = tablePtr->rows-1+tablePtr->rowOffset;
+ lastCol = tablePtr->cols-1+tablePtr->colOffset;
+ if (tablePtr->selectTitles) {
+ firstRow = tablePtr->rowOffset;
+ firstCol = tablePtr->colOffset;
+ } else {
+ firstRow = tablePtr->titleRows+tablePtr->rowOffset;
+ firstCol = tablePtr->titleCols+tablePtr->colOffset;
+ }
+ /* maintain appropriate user index */
+ CONSTRAIN(row, firstRow, lastRow);
+ CONSTRAIN(col, firstCol, lastCol);
+ if (objc == 4) {
+ r1 = r2 = row;
+ c1 = c2 = col;
+ } else {
+ CONSTRAIN(r2, firstRow, lastRow);
+ CONSTRAIN(c2, firstCol, lastCol);
+ r1 = MIN(row,r2); r2 = MAX(row,r2);
+ c1 = MIN(col,c2); c2 = MAX(col,c2);
+ }
+ switch (tablePtr->selectType) {
+ case SEL_BOTH:
+ if (firstCol > lastCol) c2--; /* No selectable columns in table */
+ if (firstRow > lastRow) r2--; /* No selectable rows in table */
+ clo = c1; chi = c2;
+ c1 = firstCol;
+ c2 = lastCol;
+ key = 1;
+ goto SET_CELLS;
+ SET_BOTH:
+ key = 0;
+ c1 = clo; c2 = chi;
+ case SEL_COL:
+ r1 = firstRow;
+ r2 = lastRow;
+ if (firstCol > lastCol) c2--; /* No selectable columns in table */
+ break;
+ case SEL_ROW:
+ c1 = firstCol;
+ c2 = lastCol;
+ if (firstRow>lastRow) r2--; /* No selectable rows in table */
+ break;
+ }
+SET_CELLS:
+ entryPtr = Tcl_FirstHashEntry(tablePtr->selCells, &search);
+ for ( row = r1; row <= r2; row++ ) {
+ for ( col = c1; col <= c2; col++ ) {
+ TableMakeArrayIndex(row, col, buf1);
+ if (Tcl_FindHashEntry(tablePtr->selCells, buf1) == NULL) {
+ Tcl_CreateHashEntry(tablePtr->selCells, buf1, &dummy);
+ TableRefresh(tablePtr, row-tablePtr->rowOffset,
+ col-tablePtr->colOffset, CELL);
+ }
+ }
+ }
+ if (key) goto SET_BOTH;
+
+ /* Adjust the table for top left, selection on screen etc */
+ TableAdjustParams(tablePtr);
+
+ /* If the table was previously empty and we want to export the
+ * selection, we should grab it now */
+ if (entryPtr == NULL && tablePtr->exportSelection) {
+ Tk_OwnSelection(tablePtr->tkwin, XA_PRIMARY, TableLostSelection,
+ (ClientData) tablePtr);
+ }
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_ViewCmd --
+ * This procedure is invoked to process the x|yview method
+ * that corresponds to a table widget managed by this module.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+int
+Table_ViewCmd(ClientData clientData, register Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ register Table *tablePtr = (Table *) clientData;
+ int row, col, value;
+ char *xy;
+
+ /* Check xview or yview */
+ if (objc > 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?args?");
+ return TCL_ERROR;
+ }
+ xy = Tcl_GetString(objv[1]);
+
+ if (objc == 2) {
+ Tcl_Obj *resultPtr;
+ int diff, x, y, w, h;
+ double first, last;
+
+ resultPtr = Tcl_GetObjResult(interp);
+ TableGetLastCell(tablePtr, &row, &col);
+ TableCellVCoords(tablePtr, row, col, &x, &y, &w, &h, 0);
+ if (*xy == 'y') {
+ if (row < tablePtr->titleRows) {
+ first = 0;
+ last = 1;
+ } else {
+ diff = tablePtr->rowStarts[tablePtr->titleRows];
+ last = (double) (tablePtr->rowStarts[tablePtr->rows]-diff);
+ first = (tablePtr->rowStarts[tablePtr->topRow]-diff) / last;
+ last = (h+tablePtr->rowStarts[row]-diff) / last;
+ }
+ } else {
+ if (col < tablePtr->titleCols) {
+ first = 0;
+ last = 1;
+ } else {
+ diff = tablePtr->colStarts[tablePtr->titleCols];
+ last = (double) (tablePtr->colStarts[tablePtr->cols]-diff);
+ first = (tablePtr->colStarts[tablePtr->leftCol]-diff) / last;
+ last = (w+tablePtr->colStarts[col]-diff) / last;
+ }
+ }
+ Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewDoubleObj(first));
+ Tcl_ListObjAppendElement(NULL, resultPtr, Tcl_NewDoubleObj(last));
+ } else {
+ /* cache old topleft to see if it changes */
+ int oldTop = tablePtr->topRow, oldLeft = tablePtr->leftCol;
+
+ if (objc == 3) {
+ if (Tcl_GetIntFromObj(interp, objv[2], &value) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (*xy == 'y') {
+ tablePtr->topRow = value + tablePtr->titleRows;
+ } else {
+ tablePtr->leftCol = value + tablePtr->titleCols;
+ }
+ } else {
+ int result;
+ double frac;
+#if (TK_MINOR_VERSION > 0) /* 8.1+ */
+ result = Tk_GetScrollInfoObj(interp, objc, objv, &frac, &value);
+#else
+ int i;
+ char **argv = (char **) ckalloc((objc + 1) * sizeof(char *));
+ for (i = 0; i < objc; i++) {
+ argv[i] = Tcl_GetString(objv[i]);
+ }
+ argv[i] = NULL;
+ result = Tk_GetScrollInfo(interp, objc, argv, &frac, &value);
+ ckfree ((char *) argv);
+#endif
+ switch (result) {
+ case TK_SCROLL_ERROR:
+ return TCL_ERROR;
+ case TK_SCROLL_MOVETO:
+ if (frac < 0) frac = 0;
+ if (*xy == 'y') {
+ tablePtr->topRow = (int)(frac*tablePtr->rows)
+ +tablePtr->titleRows;
+ } else {
+ tablePtr->leftCol = (int)(frac*tablePtr->cols)
+ +tablePtr->titleCols;
+ }
+ break;
+ case TK_SCROLL_PAGES:
+ TableGetLastCell(tablePtr, &row, &col);
+ if (*xy == 'y') {
+ tablePtr->topRow += value * (row-tablePtr->topRow+1);
+ } else {
+ tablePtr->leftCol += value * (col-tablePtr->leftCol+1);
+ }
+ break;
+ case TK_SCROLL_UNITS:
+ if (*xy == 'y') {
+ tablePtr->topRow += value;
+ } else {
+ tablePtr->leftCol += value;
+ }
+ break;
+ }
+ }
+ /* maintain appropriate real index */
+ CONSTRAIN(tablePtr->topRow, tablePtr->titleRows, tablePtr->rows-1);
+ CONSTRAIN(tablePtr->leftCol, tablePtr->titleCols, tablePtr->cols-1);
+ /* Do the table adjustment if topRow || leftCol changed */
+ if (oldTop != tablePtr->topRow || oldLeft != tablePtr->leftCol) {
+ TableAdjustParams(tablePtr);
+ }
+ }
+
+ return TCL_OK;
+}
+
+#if 0
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_Cmd --
+ * This procedure is invoked to process the CMD method
+ * that corresponds to a table widget managed by this module.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+int
+Table_Cmd(ClientData clientData, register Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ register Table *tablePtr = (Table *) clientData;
+ int result = TCL_OK;
+
+ return result;
+}
+#endif
diff --git a/libgui/src/tkTableEdit.c b/libgui/src/tkTableEdit.c
new file mode 100644
index 00000000000..3fd6d4879b0
--- /dev/null
+++ b/libgui/src/tkTableEdit.c
@@ -0,0 +1,683 @@
+/*
+ * tkTableEdit.c --
+ *
+ * This module implements editing functions of a table widget.
+ *
+ * Copyright (c) 1998-2000 Jeffrey Hobbs
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id$
+ */
+
+#include "tkTable.h"
+
+static void TableModifyRC _ANSI_ARGS_((register Table *tablePtr,
+ int doRows, int movetag,
+ Tcl_HashTable *tagTblPtr, Tcl_HashTable *dimTblPtr,
+ int offset, int from, int to, int lo, int hi,
+ int outOfBounds));
+
+/* insert/delete subcommands */
+static char *modCmdNames[] = {
+ "active", "cols", "rows", (char *)NULL
+};
+enum modCmd {
+ MOD_ACTIVE, MOD_COLS, MOD_ROWS
+};
+
+/* insert/delete row/col switches */
+static char *rcCmdNames[] = {
+ "-keeptitles", "-holddimensions", "-holdselection",
+ "-holdtags", "-holdwindows", "--",
+ (char *) NULL
+};
+enum rcCmd {
+ OPT_TITLES, OPT_DIMS, OPT_SEL,
+ OPT_TAGS, OPT_WINS, OPT_LAST
+};
+
+#define HOLD_TITLES 1<<0
+#define HOLD_DIMS 1<<1
+#define HOLD_TAGS 1<<2
+#define HOLD_WINS 1<<3
+#define HOLD_SEL 1<<4
+
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_EditCmd --
+ * This procedure is invoked to process the insert/delete method
+ * that corresponds to a table widget managed by this module.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+int
+Table_EditCmd(ClientData clientData, register Tcl_Interp *interp,
+ int objc, Tcl_Obj *CONST objv[])
+{
+ register Table *tablePtr = (Table *) clientData;
+ int doInsert, cmdIndex, first, last;
+
+ if (objc < 4) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "option ?switches? arg ?arg?");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[2], modCmdNames,
+ "option", 0, &cmdIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ doInsert = (*(Tcl_GetString(objv[1])) == 'i');
+ switch ((enum modCmd) cmdIndex) {
+ case MOD_ACTIVE:
+ if (doInsert) {
+ /* INSERT */
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 3, objv, "index string");
+ return TCL_ERROR;
+ }
+ if (TableGetIcursorObj(tablePtr, objv[3], &first) != TCL_OK) {
+ return TCL_ERROR;
+ } else if ((tablePtr->flags & HAS_ACTIVE) &&
+ !(tablePtr->flags & ACTIVE_DISABLED) &&
+ tablePtr->state == STATE_NORMAL) {
+ TableInsertChars(tablePtr, first, Tcl_GetString(objv[4]));
+ }
+ } else {
+ /* DELETE */
+ if (objc > 5) {
+ Tcl_WrongNumArgs(interp, 3, objv, "first ?last?");
+ return TCL_ERROR;
+ }
+ if (TableGetIcursorObj(tablePtr, objv[3], &first) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (objc == 4) {
+ last = first+1;
+ } else if (TableGetIcursorObj(tablePtr, objv[4],
+ &last) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if ((last >= first) && (tablePtr->flags & HAS_ACTIVE) &&
+ !(tablePtr->flags & ACTIVE_DISABLED) &&
+ tablePtr->state == STATE_NORMAL) {
+ TableDeleteChars(tablePtr, first, last-first);
+ }
+ }
+ break; /* EDIT ACTIVE */
+
+ case MOD_COLS:
+ case MOD_ROWS: {
+ /*
+ * ROW/COL INSERTION/DELETION
+ * FIX: This doesn't handle spans
+ */
+ int i, lo, hi, argsLeft, offset, minkeyoff, doRows;
+ int maxrow, maxcol, maxkey, minkey, flags, count, *dimPtr;
+ Tcl_HashTable *tagTblPtr, *dimTblPtr;
+ Tcl_HashSearch search;
+
+ doRows = (cmdIndex == MOD_ROWS);
+ flags = 0;
+ for (i = 3; i < objc; i++) {
+ if (*(Tcl_GetString(objv[i])) != '-') {
+ break;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[i], rcCmdNames,
+ "switch", 0, &cmdIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (cmdIndex == OPT_LAST) {
+ i++;
+ break;
+ }
+ switch (cmdIndex) {
+ case OPT_TITLES:
+ flags |= HOLD_TITLES;
+ break;
+ case OPT_DIMS:
+ flags |= HOLD_DIMS;
+ break;
+ case OPT_SEL:
+ flags |= HOLD_SEL;
+ break;
+ case OPT_TAGS:
+ flags |= HOLD_TAGS;
+ break;
+ case OPT_WINS:
+ flags |= HOLD_WINS;
+ break;
+ }
+ }
+ argsLeft = objc - i;
+ if (argsLeft < 1 || argsLeft > 2) {
+ Tcl_WrongNumArgs(interp, 3, objv, "?switches? index ?count?");
+ return TCL_ERROR;
+ }
+
+ count = 1;
+ maxcol = tablePtr->cols-1+tablePtr->colOffset;
+ maxrow = tablePtr->rows-1+tablePtr->rowOffset;
+ if (strcmp(Tcl_GetString(objv[i]), "end") == 0) {
+ /* allow "end" to be specified as an index */
+ first = (doRows) ? maxrow : maxcol;
+ } else if (Tcl_GetIntFromObj(interp, objv[i], &first) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (argsLeft == 2 &&
+ Tcl_GetIntFromObj(interp, objv[++i], &count) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (count == 0 || (tablePtr->state == STATE_DISABLED)) {
+ return TCL_OK;
+ }
+
+ if (doRows) {
+ maxkey = maxrow;
+ minkey = tablePtr->rowOffset;
+ minkeyoff = tablePtr->rowOffset+tablePtr->titleRows;
+ offset = tablePtr->rowOffset;
+ tagTblPtr = tablePtr->rowStyles;
+ dimTblPtr = tablePtr->rowHeights;
+ dimPtr = &(tablePtr->rows);
+ lo = tablePtr->colOffset
+ + ((flags & HOLD_TITLES) ? tablePtr->titleCols : 0);
+ hi = maxcol;
+ } else {
+ maxkey = maxcol;
+ minkey = tablePtr->colOffset;
+ minkeyoff = tablePtr->colOffset+tablePtr->titleCols;
+ offset = tablePtr->colOffset;
+ tagTblPtr = tablePtr->colStyles;
+ dimTblPtr = tablePtr->colWidths;
+ dimPtr = &(tablePtr->cols);
+ lo = tablePtr->rowOffset
+ + ((flags & HOLD_TITLES) ? tablePtr->titleRows : 0);
+ hi = maxrow;
+ }
+
+ /* constrain the starting index */
+ if (first > maxkey) {
+ first = maxkey;
+ } else if (first < minkey) {
+ first = minkey;
+ }
+ if (doInsert) {
+ /* +count means insert after index,
+ * -count means insert before index */
+ if (count < 0) {
+ count = -count;
+ } else {
+ first++;
+ }
+ if ((flags & HOLD_TITLES) && (first < minkeyoff)) {
+ count -= minkeyoff-first;
+ if (count <= 0) {
+ return TCL_OK;
+ }
+ first = minkeyoff;
+ }
+ if (!(flags & HOLD_DIMS)) {
+ maxkey += count;
+ *dimPtr += count;
+ }
+ for (i = maxkey; i >= first; i--) {
+ /* move row/col style && width/height here */
+ TableModifyRC(tablePtr, doRows, flags, tagTblPtr, dimTblPtr,
+ offset, i, i-count, lo, hi, ((i-count) < first));
+ }
+ } else {
+ /* (index = i && count = 1) == (index = i && count = -1) */
+ if (count < 0) {
+ /* if the count is negative, make sure that the col count will
+ * delete no greater than the original index */
+ if (first+count < minkey) {
+ if (first-minkey < abs(count)) {
+ /*
+ * In this case, the user is asking to delete more rows
+ * than exist before the minkey, so we have to shrink
+ * the count down to the existing rows up to index.
+ */
+ count = first-minkey;
+ } else {
+ count += first-minkey;
+ }
+ first = minkey;
+ } else {
+ first += count;
+ count = -count;
+ }
+ }
+ if ((flags & HOLD_TITLES) && (first <= minkeyoff)) {
+ count -= minkeyoff-first;
+ if (count <= 0) {
+ return TCL_OK;
+ }
+ first = minkeyoff;
+ }
+ if (count > maxkey-first+1) {
+ count = maxkey-first+1;
+ }
+ if (!(flags & HOLD_DIMS)) {
+ *dimPtr -= count;
+ }
+ for (i = first; i <= maxkey; i++) {
+ TableModifyRC(tablePtr, doRows, flags, tagTblPtr, dimTblPtr,
+ offset, i, i+count, lo, hi, ((i+count) > maxkey));
+ }
+ }
+ if (!(flags & HOLD_SEL) &&
+ Tcl_FirstHashEntry(tablePtr->selCells, &search) != NULL) {
+ /* clear selection - forceful, but effective */
+ Tcl_DeleteHashTable(tablePtr->selCells);
+ Tcl_InitHashTable(tablePtr->selCells, TCL_STRING_KEYS);
+ }
+
+ /*
+ * Make sure that the modified dimension is actually legal
+ * after removing all that stuff.
+ */
+ *dimPtr = MAX(1, *dimPtr);
+
+ TableAdjustParams(tablePtr);
+ /* change the geometry */
+ TableGeometryRequest(tablePtr);
+ /* FIX:
+ * This has to handle when the previous rows/cols resize because
+ * of the *stretchmode. InvalidateAll does that, but could be
+ * more efficient.
+ */
+ TableInvalidateAll(tablePtr, 0);
+ break;
+ }
+
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TableDeleteChars --
+ * Remove one or more characters from an table widget.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory gets freed, the table gets modified and (eventually)
+ * redisplayed.
+ *
+ *----------------------------------------------------------------------
+ */
+void
+TableDeleteChars(tablePtr, index, count)
+ register Table *tablePtr; /* Table widget to modify. */
+ int index; /* Index of first character to delete. */
+ int count; /* How many characters to delete. */
+{
+#ifdef TCL_UTF_MAX
+ int byteIndex, byteCount, newByteCount, numBytes, numChars;
+ char *new, *string;
+
+ string = tablePtr->activeBuf;
+ numBytes = strlen(string);
+ numChars = Tcl_NumUtfChars(string, numBytes);
+ if ((index + count) > numChars) {
+ count = numChars - index;
+ }
+ if (count <= 0) {
+ return;
+ }
+
+ byteIndex = Tcl_UtfAtIndex(string, index) - string;
+ byteCount = Tcl_UtfAtIndex(string + byteIndex, count)
+ - (string + byteIndex);
+
+ newByteCount = numBytes + 1 - byteCount;
+ new = (char *) ckalloc((unsigned) newByteCount);
+ memcpy(new, string, (size_t) byteIndex);
+ strcpy(new + byteIndex, string + byteIndex + byteCount);
+#else
+ int oldlen;
+ char *new;
+
+ /* this gets the length of the string, as well as ensuring that
+ * the cursor isn't beyond the end char */
+ TableGetIcursor(tablePtr, "end", &oldlen);
+
+ if ((index+count) > oldlen)
+ count = oldlen-index;
+ if (count <= 0)
+ return;
+
+ new = (char *) ckalloc((unsigned)(oldlen-count+1));
+ strncpy(new, tablePtr->activeBuf, (size_t) index);
+ strcpy(new+index, tablePtr->activeBuf+index+count);
+ /* make sure this string is null terminated */
+ new[oldlen-count] = '\0';
+#endif
+ /* This prevents deletes on BREAK or validation error. */
+ if (tablePtr->validate &&
+ TableValidateChange(tablePtr, tablePtr->activeRow+tablePtr->rowOffset,
+ tablePtr->activeCol+tablePtr->colOffset,
+ tablePtr->activeBuf, new, index) != TCL_OK) {
+ ckfree(new);
+ return;
+ }
+
+ ckfree(tablePtr->activeBuf);
+ tablePtr->activeBuf = new;
+
+ /* mark the text as changed */
+ tablePtr->flags |= TEXT_CHANGED;
+
+ if (tablePtr->icursor >= index) {
+ if (tablePtr->icursor >= (index+count)) {
+ tablePtr->icursor -= count;
+ } else {
+ tablePtr->icursor = index;
+ }
+ }
+
+ TableSetActiveIndex(tablePtr);
+
+ TableRefresh(tablePtr, tablePtr->activeRow, tablePtr->activeCol, CELL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TableInsertChars --
+ * Add new characters to the active cell of a table widget.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * New information gets added to tablePtr; it will be redisplayed
+ * soon, but not necessarily immediately.
+ *
+ *----------------------------------------------------------------------
+ */
+void
+TableInsertChars(tablePtr, index, value)
+ register Table *tablePtr; /* Table that is to get the new elements. */
+ int index; /* Add the new elements before this element. */
+ char *value; /* New characters to add (NULL-terminated
+ * string). */
+{
+#ifdef TCL_UTF_MAX
+ int oldlen, byteIndex, byteCount;
+ char *new, *string;
+
+ byteCount = strlen(value);
+ if (byteCount == 0) {
+ return;
+ }
+
+ /* Is this an autoclear and this is the first update */
+ /* Note that this clears without validating */
+ if (tablePtr->autoClear && !(tablePtr->flags & TEXT_CHANGED)) {
+ /* set the buffer to be empty */
+ tablePtr->activeBuf = (char *)ckrealloc(tablePtr->activeBuf, 1);
+ tablePtr->activeBuf[0] = '\0';
+ /* the insert position now has to be 0 */
+ index = 0;
+ tablePtr->icursor = 0;
+ }
+
+ string = tablePtr->activeBuf;
+ byteIndex = Tcl_UtfAtIndex(string, index) - string;
+
+ oldlen = strlen(string);
+ new = (char *) ckalloc((unsigned)(oldlen + byteCount + 1));
+ memcpy(new, string, (size_t) byteIndex);
+ strcpy(new + byteIndex, value);
+ strcpy(new + byteIndex + byteCount, string + byteIndex);
+
+ /* validate potential new active buffer */
+ /* This prevents inserts on either BREAK or validation error. */
+ if (tablePtr->validate &&
+ TableValidateChange(tablePtr, tablePtr->activeRow+tablePtr->rowOffset,
+ tablePtr->activeCol+tablePtr->colOffset,
+ tablePtr->activeBuf, new, byteIndex) != TCL_OK) {
+ ckfree(new);
+ return;
+ }
+
+ /*
+ * The following construction is used because inserting improperly
+ * formed UTF-8 sequences between other improperly formed UTF-8
+ * sequences could result in actually forming valid UTF-8 sequences;
+ * the number of characters added may not be Tcl_NumUtfChars(string, -1),
+ * because of context. The actual number of characters added is how
+ * many characters were are in the string now minus the number that
+ * used to be there.
+ */
+
+ if (tablePtr->icursor >= index) {
+ tablePtr->icursor += Tcl_NumUtfChars(new, oldlen+byteCount)
+ - Tcl_NumUtfChars(tablePtr->activeBuf, oldlen);
+ }
+
+ ckfree(string);
+ tablePtr->activeBuf = new;
+
+#else
+ int oldlen, newlen;
+ char *new;
+
+ newlen = strlen(value);
+ if (newlen == 0) return;
+
+ /* Is this an autoclear and this is the first update */
+ /* Note that this clears without validating */
+ if (tablePtr->autoClear && !(tablePtr->flags & TEXT_CHANGED)) {
+ /* set the buffer to be empty */
+ tablePtr->activeBuf = (char *)ckrealloc(tablePtr->activeBuf, 1);
+ tablePtr->activeBuf[0] = '\0';
+ /* the insert position now has to be 0 */
+ index = 0;
+ }
+ oldlen = strlen(tablePtr->activeBuf);
+ /* get the buffer to at least the right length */
+ new = (char *) ckalloc((unsigned)(oldlen+newlen+1));
+ strncpy(new, tablePtr->activeBuf, (size_t) index);
+ strcpy(new+index, value);
+ strcpy(new+index+newlen, (tablePtr->activeBuf)+index);
+ /* make sure this string is null terminated */
+ new[oldlen+newlen] = '\0';
+
+ /* validate potential new active buffer */
+ /* This prevents inserts on either BREAK or validation error. */
+ if (tablePtr->validate &&
+ TableValidateChange(tablePtr, tablePtr->activeRow+tablePtr->rowOffset,
+ tablePtr->activeCol+tablePtr->colOffset,
+ tablePtr->activeBuf, new, index) != TCL_OK) {
+ ckfree(new);
+ return;
+ }
+ ckfree(tablePtr->activeBuf);
+ tablePtr->activeBuf = new;
+
+ if (tablePtr->icursor >= index) {
+ tablePtr->icursor += newlen;
+ }
+#endif
+
+ /* mark the text as changed */
+ tablePtr->flags |= TEXT_CHANGED;
+
+ TableSetActiveIndex(tablePtr);
+
+ TableRefresh(tablePtr, tablePtr->activeRow, tablePtr->activeCol, CELL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TableModifyRC --
+ * Helper function that does the core work of moving rows/cols
+ * and associated tags.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Moves cell data and possibly tag data
+ *
+ *----------------------------------------------------------------------
+ */
+static void
+TableModifyRC(tablePtr, doRows, flags, tagTblPtr, dimTblPtr,
+ offset, from, to, lo, hi, outOfBounds)
+ Table *tablePtr; /* Information about text widget. */
+ int doRows; /* rows (1) or cols (0) */
+ int flags; /* flags indicating what to move */
+ Tcl_HashTable *tagTblPtr, *dimTblPtr; /* Pointers to the row/col tags
+ * and width/height tags */
+ int offset; /* appropriate offset */
+ int from, to; /* the from and to row/col */
+ int lo, hi; /* the lo and hi col/row */
+ int outOfBounds; /* the boundary check for shifting items */
+{
+ int j, new;
+ char buf[INDEX_BUFSIZE], buf1[INDEX_BUFSIZE];
+ Tcl_HashEntry *entryPtr, *newPtr;
+ TableEmbWindow *ewPtr;
+
+ /*
+ * move row/col style && width/height here
+ * If -holdtags is specified, we don't move the user-set widths/heights
+ * of the absolute rows/columns, otherwise we enter here to move the
+ * dimensions appropriately
+ */
+ if (!(flags & HOLD_TAGS)) {
+ entryPtr = Tcl_FindHashEntry(tagTblPtr, (char *)from);
+ if (entryPtr != NULL) {
+ Tcl_DeleteHashEntry(entryPtr);
+ }
+ entryPtr = Tcl_FindHashEntry(dimTblPtr, (char *)from-offset);
+ if (entryPtr != NULL) {
+ Tcl_DeleteHashEntry(entryPtr);
+ }
+ if (!outOfBounds) {
+ entryPtr = Tcl_FindHashEntry(tagTblPtr, (char *)to);
+ if (entryPtr != NULL) {
+ newPtr = Tcl_CreateHashEntry(tagTblPtr, (char *)from, &new);
+ Tcl_SetHashValue(newPtr, Tcl_GetHashValue(entryPtr));
+ Tcl_DeleteHashEntry(entryPtr);
+ }
+ entryPtr = Tcl_FindHashEntry(dimTblPtr, (char *)to-offset);
+ if (entryPtr != NULL) {
+ newPtr = Tcl_CreateHashEntry(dimTblPtr, (char *)from-offset,
+ &new);
+ Tcl_SetHashValue(newPtr, Tcl_GetHashValue(entryPtr));
+ Tcl_DeleteHashEntry(entryPtr);
+ }
+ }
+ }
+ for (j = lo; j <= hi; j++) {
+ if (doRows /* rows */) {
+ TableMakeArrayIndex(from, j, buf);
+ TableMakeArrayIndex(to, j, buf1);
+ TableMoveCellValue(tablePtr, to, j, buf1, from, j, buf,
+ outOfBounds);
+ } else {
+ TableMakeArrayIndex(j, from, buf);
+ TableMakeArrayIndex(j, to, buf1);
+ TableMoveCellValue(tablePtr, j, to, buf1, j, from, buf,
+ outOfBounds);
+ }
+ /*
+ * If -holdselection is specified, we leave the selected cells in the
+ * absolute cell values, otherwise we enter here to move the
+ * selection appropriately
+ */
+ if (!(flags & HOLD_SEL)) {
+ entryPtr = Tcl_FindHashEntry(tablePtr->selCells, buf);
+ if (entryPtr != NULL) {
+ Tcl_DeleteHashEntry(entryPtr);
+ }
+ if (!outOfBounds) {
+ entryPtr = Tcl_FindHashEntry(tablePtr->selCells, buf1);
+ if (entryPtr != NULL) {
+ Tcl_CreateHashEntry(tablePtr->selCells, buf, &new);
+ Tcl_DeleteHashEntry(entryPtr);
+ }
+ }
+ }
+ /*
+ * If -holdtags is specified, we leave the tags in the
+ * absolute cell values, otherwise we enter here to move the
+ * tags appropriately
+ */
+ if (!(flags & HOLD_TAGS)) {
+ entryPtr = Tcl_FindHashEntry(tablePtr->cellStyles, buf);
+ if (entryPtr != NULL) {
+ Tcl_DeleteHashEntry(entryPtr);
+ }
+ if (!outOfBounds) {
+ entryPtr = Tcl_FindHashEntry(tablePtr->cellStyles, buf1);
+ if (entryPtr != NULL) {
+ newPtr = Tcl_CreateHashEntry(tablePtr->cellStyles, buf,
+ &new);
+ Tcl_SetHashValue(newPtr, Tcl_GetHashValue(entryPtr));
+ Tcl_DeleteHashEntry(entryPtr);
+ }
+ }
+ }
+ /*
+ * If -holdwindows is specified, we leave the windows in the
+ * absolute cell values, otherwise we enter here to move the
+ * windows appropriately
+ */
+ if (!(flags & HOLD_WINS)) {
+ /*
+ * Delete whatever window might be in our destination
+ */
+ Table_WinDelete(tablePtr, buf);
+ if (!outOfBounds) {
+ /*
+ * buf1 is where the window is
+ * buf is where we want it to be
+ *
+ * This is an adaptation of Table_WinMove, which we can't
+ * use because we are intermediately fiddling with boundaries
+ */
+ entryPtr = Tcl_FindHashEntry(tablePtr->winTable, buf1);
+ if (entryPtr != NULL) {
+ /*
+ * If there was a window in our source,
+ * get the window pointer to move it
+ */
+ ewPtr = (TableEmbWindow *) Tcl_GetHashValue(entryPtr);
+ /* and free the old hash table entry */
+ Tcl_DeleteHashEntry(entryPtr);
+
+ entryPtr = Tcl_CreateHashEntry(tablePtr->winTable, buf,
+ &new);
+ /*
+ * We needn't check if a window was in buf, since the
+ * Table_WinDelete above should guarantee that no window
+ * is there. Just set the new entry's value.
+ */
+ Tcl_SetHashValue(entryPtr, (ClientData) ewPtr);
+ ewPtr->hPtr = entryPtr;
+ }
+ }
+ }
+ }
+}
diff --git a/libgui/src/tkTableInitScript.h b/libgui/src/tkTableInitScript.h
new file mode 100644
index 00000000000..1084717757b
--- /dev/null
+++ b/libgui/src/tkTableInitScript.h
@@ -0,0 +1,90 @@
+/*
+ * tkTableInitScript.h --
+ *
+ * This file contains common init script for tkTable
+ *
+ * Copyright (c) 1998 Jeffrey Hobbs
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+/*
+ * The following string is the startup script executed when the table is
+ * loaded. It looks on disk in several different directories for a script
+ * "TBL_RUNTIME" (as defined in Makefile) that is compatible with this
+ * version of tkTable. The sourced script has all key bindings defined.
+ */
+
+static char tkTableInitScript[] = "if {[info proc tkTableInit]==\"\"} {\n\
+ proc tkTableInit {} {\n\
+ global tk_library tcl_pkgPath errorInfo env\n\
+ rename tkTableInit {}\n\
+ set errors {}\n\
+ if {![info exists env(TK_TABLE_LIBRARY_FILE)]} {\n\
+ set env(TK_TABLE_LIBRARY_FILE) " TBL_RUNTIME "\n\
+ }\n\
+ if {[info exists env(TK_TABLE_LIBRARY)]} {\n\
+ lappend dirs $env(TK_TABLE_LIBRARY)\n\
+ }\n\
+ lappend dirs " TBL_RUNTIME_DIR "\n\
+ if {[info exists tcl_pkgPath]} {\n\
+ foreach i $tcl_pkgPath {\n\
+ lappend dirs [file join $i Tktable" TBL_VERSION "] \\\n\
+ [file join $i Tktable] $i\n\
+ }\n\
+ }\n\
+ lappend dirs $tk_library [pwd]\n\
+ foreach i $dirs {\n\
+ set try [file join $i $env(TK_TABLE_LIBRARY_FILE)]\n\
+ if {[file exists $try]} {\n\
+ if {![catch {uplevel #0 [list source $try]} msg]} {\n\
+ set env(TK_TABLE_LIBRARY) $i\n\
+ return\n\
+ } else {\n\
+ append errors \"$try: $msg\n$errorInfo\n\"\n\
+ }\n\
+ }\n\
+ }\n"
+#ifdef NO_EMBEDDED_RUNTIME
+" set msg \"Can't find a $env(TK_TABLE_LIBRARY_FILE) in the following directories: \n\"\n\
+ append msg \" $dirs\n\n$errors\n\n\"\n\
+ append msg \"This probably means that TkTable wasn't installed properly.\"\n\
+ return -code error $msg\n"
+#else
+" set env(TK_TABLE_LIBRARY) EMBEDDED_RUNTIME\n"
+# ifdef MAC_TCL
+" source -rsrc tkTable"
+# else
+" uplevel #0 {"
+# include "tkTable.tcl.h"
+" }"
+# endif
+#endif
+" }\n\
+}\n\
+tkTableInit";
+
+/*
+ * The init script can't make certain calls in a safe interpreter,
+ * so we always have to use the embedded runtime for it
+ */
+static char tkTableSafeInitScript[] = "if {[info proc tkTableInit]==\"\"} {\n\
+ proc tkTableInit {} {\n\
+ set env(TK_TABLE_LIBRARY) EMBEDDED_RUNTIME\n"
+#ifdef NO_EMBEDDED_RUNTIME
+" append msg \"tkTable requires embedded runtime to be compiled for\"\n\
+ append msg \" use in safe interpreters\"\n\
+ return -code error $msg\n"
+#endif
+# ifdef MAC_TCL
+" source -rsrc tkTable"
+# else
+" uplevel #0 {"
+# include "tkTable.tcl.h"
+" }"
+# endif
+" }\n\
+}\n\
+tkTableInit";
+
diff --git a/libgui/src/tkTablePs.c b/libgui/src/tkTablePs.c
new file mode 100644
index 00000000000..018f0791ec3
--- /dev/null
+++ b/libgui/src/tkTablePs.c
@@ -0,0 +1,1299 @@
+/*
+ * tkTablePs.c --
+ *
+ * This module implements postscript output for table widgets.
+ * Based off of Tk8.1a2 tkCanvPs.c.
+ *
+ * Copyright (c) 1991-1994 The Regents of the University of California.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
+ * changes 1998 Copyright (c) 1998 Jeffrey Hobbs
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ */
+
+#include "tkTable.h"
+
+/* This is for Tcl_DStringAppendAll */
+#if defined(__STDC__) || defined(HAS_STDARG)
+#include <stdarg.h>
+#else
+#include <varargs.h>
+#endif
+
+#ifndef TCL_INTEGER_SPACE
+/* This appears in 8.1 */
+#define TCL_INTEGER_SPACE 24
+#endif
+
+/*
+ * One of the following structures is created to keep track of Postscript
+ * output being generated. It consists mostly of information provided on
+ * the widget command line.
+ */
+
+typedef struct TkPostscriptInfo {
+ int x, y, width, height; /* Area to print, in table pixel
+ * coordinates. */
+ int x2, y2; /* x+width and y+height. */
+ char *pageXString; /* String value of "-pagex" option or NULL. */
+ char *pageYString; /* String value of "-pagey" option or NULL. */
+ double pageX, pageY; /* Postscript coordinates (in points)
+ * corresponding to pageXString and
+ * pageYString. Don't forget that y-values
+ * grow upwards for Postscript! */
+ char *pageWidthString; /* Printed width of output. */
+ char *pageHeightString; /* Printed height of output. */
+ double scale; /* Scale factor for conversion: each pixel
+ * maps into this many points. */
+ Tk_Anchor pageAnchor; /* How to anchor bbox on Postscript page. */
+ int rotate; /* Non-zero means output should be rotated
+ * on page (landscape mode). */
+ char *fontVar; /* If non-NULL, gives name of global variable
+ * containing font mapping information.
+ * Malloc'ed. */
+ char *colorVar; /* If non-NULL, give name of global variable
+ * containing color mapping information.
+ * Malloc'ed. */
+ char *colorMode; /* Mode for handling colors: "monochrome",
+ * "gray", or "color". Malloc'ed. */
+ int colorLevel; /* Numeric value corresponding to colorMode:
+ * 0 for mono, 1 for gray, 2 for color. */
+ char *fileName; /* Name of file in which to write Postscript;
+ * NULL means return Postscript info as
+ * result. Malloc'ed. */
+ char *channelName; /* If -channel is specified, the name of
+ * the channel to use. */
+ Tcl_Channel chan; /* Open channel corresponding to fileName. */
+ Tcl_HashTable fontTable; /* Hash table containing names of all font
+ * families used in output. The hash table
+ * values are not used. */
+ char *first, *last; /* table indices to start and end at */
+} TkPostscriptInfo;
+
+/*
+ * The table below provides a template that's used to process arguments
+ * to the table "postscript" command and fill in TkPostscriptInfo
+ * structures.
+ */
+
+static Tk_ConfigSpec configSpecs[] = {
+ {TK_CONFIG_STRING, "-colormap", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, colorVar), 0},
+ {TK_CONFIG_STRING, "-colormode", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, colorMode), 0},
+ {TK_CONFIG_STRING, "-file", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, fileName), 0},
+ {TK_CONFIG_STRING, "-channel", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, channelName), 0},
+ {TK_CONFIG_STRING, "-first", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, first), 0},
+ {TK_CONFIG_STRING, "-fontmap", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, fontVar), 0},
+ {TK_CONFIG_PIXELS, "-height", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, height), 0},
+ {TK_CONFIG_STRING, "-last", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, last), 0},
+ {TK_CONFIG_ANCHOR, "-pageanchor", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, pageAnchor), 0},
+ {TK_CONFIG_STRING, "-pageheight", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, pageHeightString), 0},
+ {TK_CONFIG_STRING, "-pagewidth", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, pageWidthString), 0},
+ {TK_CONFIG_STRING, "-pagex", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, pageXString), 0},
+ {TK_CONFIG_STRING, "-pagey", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, pageYString), 0},
+ {TK_CONFIG_BOOLEAN, "-rotate", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, rotate), 0},
+ {TK_CONFIG_PIXELS, "-width", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, width), 0},
+ {TK_CONFIG_PIXELS, "-x", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, x), 0},
+ {TK_CONFIG_PIXELS, "-y", (char *) NULL, (char *) NULL, "",
+ Tk_Offset(TkPostscriptInfo, y), 0},
+ {TK_CONFIG_END, (char *) NULL, (char *) NULL, (char *) NULL,
+ (char *) NULL, 0, 0}
+};
+
+/*
+ * The prolog data. Generated by str2c from prolog.ps
+ * This was split in small chunks by str2c because
+ * some C compiler have limitations on the size of static strings.
+ * (str2c is a small tcl script in tcl's tool directory (source release))
+ */
+/*
+ * This is a stripped down version of that found in tkCanvPs.c of Tk8.1a2.
+ * Comments, and stuff pertaining to stipples and other unused entities
+ * have been removed
+ */
+static CONST char * CONST prolog[]= {
+ /* Start of part 1 */
+ "%%BeginProlog\n\
+50 dict begin\n\
+\n\
+% This is standard prolog for Postscript generated by Tk's table widget.\n\
+% Based of standard prolog for Tk's canvas widget.\n\
+\n\
+% INITIALIZING VARIABLES\n\
+\n\
+/baseline 0 def\n\
+/height 0 def\n\
+/justify 0 def\n\
+/cellHeight 0 def\n\
+/cellWidth 0 def\n\
+/spacing 0 def\n\
+/strings 0 def\n\
+/xoffset 0 def\n\
+/yoffset 0 def\n\
+/x 0 def\n\
+/y 0 def\n\
+\n\
+% Define the array ISOLatin1Encoding, if it isn't already present.\n\
+\n\
+systemdict /ISOLatin1Encoding known not {\n\
+ /ISOLatin1Encoding [\n\
+ /space /space /space /space /space /space /space /space\n\
+ /space /space /space /space /space /space /space /space\n\
+ /space /space /space /space /space /space /space /space\n\
+ /space /space /space /space /space /space /space /space\n\
+ /space /exclam /quotedbl /numbersign /dollar /percent /ampersand\n\
+ /quoteright\n\
+ /parenleft /parenright /asterisk /plus /comma /minus /period /slash\n\
+ /zero /one /two /three /four /five /six /seven\n\
+ /eight /nine /colon /semicolon /less /equal /greater /question\n\
+ /at /A /B /C /D /E /F /G\n\
+ /H /I /J /K /L /M /N /O\n\
+ /P /Q /R /S /T /U /V /W\n\
+ /X /Y /Z /bracketleft /backslash /bracketright /asciicircum /underscore\n\
+ /quoteleft /a /b /c /d /e /f /g\n\
+ /h /i /j /k /l /m /n /o\n\
+ /p /q /r /s /t /u /v /w\n\
+ /x /y /z /braceleft /bar /braceright /asciitilde /space\n\
+ /space /space /space /space /space /space /space /space\n\
+ /space /space /space /space /space /space /space /space\n\
+ /dotlessi /grave /acute /circumflex /tilde /macron /breve /dotaccent\n\
+ /dieresis /space /ring /cedilla /space /hungarumlaut /ogonek /caron\n\
+ /space /exclamdown /cent /sterling /currency /yen /brokenbar /section\n\
+ /dieresis /copyright /ordfem",
+
+ "inine /guillemotleft /logicalnot /hyphen\n\
+ /registered /macron\n\
+ /degree /plusminus /twosuperior /threesuperior /acute /mu /paragraph\n\
+ /periodcentered\n\
+ /cedillar /onesuperior /ordmasculine /guillemotright /onequarter\n\
+ /onehalf /threequarters /questiondown\n\
+ /Agrave /Aacute /Acircumflex /Atilde /Adieresis /Aring /AE /Ccedilla\n\
+ /Egrave /Eacute /Ecircumflex /Edieresis /Igrave /Iacute /Icircumflex\n\
+ /Idieresis\n\
+ /Eth /Ntilde /Ograve /Oacute /Ocircumflex /Otilde /Odieresis /multiply\n\
+ /Oslash /Ugrave /Uacute /Ucircumflex /Udieresis /Yacute /Thorn\n\
+ /germandbls\n\
+ /agrave /aacute /acircumflex /atilde /adieresis /aring /ae /ccedilla\n\
+ /egrave /eacute /ecircumflex /edieresis /igrave /iacute /icircumflex\n\
+ /idieresis\n\
+ /eth /ntilde /ograve /oacute /ocircumflex /otilde /odieresis /divide\n\
+ /oslash /ugrave /uacute /ucircumflex /udieresis /yacute /thorn\n\
+ /ydieresis\n\
+ ] def\n\
+} if\n",
+
+ "\n\
+% font ISOEncode font\n\
+% This procedure changes the encoding of a font from the default\n\
+% Postscript encoding to ISOLatin1. It's typically invoked just\n\
+% before invoking \"setfont\". The body of this procedure comes from\n\
+% Section 5.6.1 of the Postscript book.\n\
+\n\
+/ISOEncode {\n\
+ dup length dict begin\n\
+ {1 index /FID ne {def} {pop pop} ifelse} forall\n\
+ /Encoding ISOLatin1Encoding def\n\
+ currentdict\n\
+ end\n\
+\n\
+ % I'm not sure why it's necessary to use \"definefont\" on this new\n\
+ % font, but it seems to be important; just use the name \"Temporary\"\n\
+ % for the font.\n\
+\n\
+ /Temporary exch definefont\n\
+} bind def\n\
+\n\
+% -- AdjustColor --\n\
+% Given a color value already set for output by the caller, adjusts\n\
+% that value to a grayscale or mono value if requested by the CL variable.\n\
+\n\
+/AdjustColor {\n\
+ setrgbcolor\n\
+ CL 2 lt {\n\
+ currentgray\n\
+ CL 0 eq {\n\
+ .5 lt {0} {1} ifelse\n\
+ } if\n\
+ setgray\n\
+ } if\n\
+} bind def\n\
+\n\
+% pointSize fontName SetFont\n\
+% The ISOEncode shouldn't be done to Symbol fonts...\n\
+/SetFont {\n\
+ findfont exch scalefont ISOEncode setfont\n\
+} def\n\
+\n",
+
+ "% x y strings spacing xoffset yoffset justify ... DrawText --\n\
+% This procedure does all of the real work of drawing text. The\n\
+% color and font must already have been set by the caller, and the\n\
+% following arguments must be on the stack:\n\
+%\n\
+% x, y - Coordinates at which to draw text.\n\
+% strings - An array of strings, one for each line of the text item,\n\
+% in order from top to bottom.\n\
+% spacing - Spacing between lines.\n\
+% xoffset - Horizontal offset for text bbox relative to x and y: 0 for\n\
+% nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se.\n\
+% yoffset - Vertical offset for text bbox relative to x and y: 0 for\n\
+% nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se.\n\
+% justify - 0 for left justification, 0.5 for center, 1 for right justify.\n\
+% cellWidth - width for this cell\n\
+% cellHeight - height for this cell\n\
+%\n\
+% Also, when this procedure is invoked, the color and font must already\n\
+% have been set for the text.\n\
+\n",
+
+ "/DrawCellText {\n\
+ /cellHeight exch def\n\
+ /cellWidth exch def\n\
+ /justify exch def\n\
+ /yoffset exch def\n\
+ /xoffset exch def\n\
+ /spacing exch def\n\
+ /strings exch def\n\
+ /y exch def\n\
+ /x exch def\n\
+\n\
+ % Compute the baseline offset and the actual font height.\n\
+\n\
+ 0 0 moveto (TXygqPZ) false charpath\n\
+ pathbbox dup /baseline exch def\n\
+ exch pop exch sub /height exch def pop\n\
+ newpath\n\
+\n\
+ % Translate coordinates first so that the origin is at the upper-left\n\
+ % corner of the text's bounding box. Remember that x and y for\n\
+ % positioning are still on the stack.\n\
+\n\
+ col0 x sub row0 y sub translate\n\
+ cellWidth xoffset mul\n\
+ strings length 1 sub spacing mul height add yoffset mul translate\n\
+\n\
+ % Now use the baseline and justification information to translate so\n\
+ % that the origin is at the baseline and positioning point for the\n\
+ % first line of text.\n\
+\n\
+ justify cellWidth mul baseline neg translate\n\
+\n\
+ % Iterate over each of the lines to output it. For each line,\n\
+ % compute its width again so it can be properly justified, then\n\
+ % display it.\n\
+\n\
+ strings {\n\
+ dup stringwidth pop\n\
+ justify neg mul 0 moveto\n\
+ show\n\
+ 0 spacing neg translate\n\
+ } forall\n\
+} bind def\n\
+\n",
+
+ "%\n\
+% x, y - Coordinates at which to draw text.\n\
+% strings - An array of strings, one for each line of the text item,\n\
+% in order from top to bottom.\n\
+% spacing - Spacing between lines.\n\
+% xoffset - Horizontal offset for text bbox relative to x and y: 0 for\n\
+% nw/w/sw anchor, -0.5 for n/center/s, and -1.0 for ne/e/se.\n\
+% yoffset - Vertical offset for text bbox relative to x and y: 0 for\n\
+% nw/n/ne anchor, +0.5 for w/center/e, and +1.0 for sw/s/se.\n\
+% justify - 0 for left justification, 0.5 for center, 1 for right justify.\n\
+% cellWidth - width for this cell\n\
+% cellHeight - height for this cell\n\
+%\n\
+% Also, when this procedure is invoked, the color and font must already\n\
+% have been set for the text.\n\
+\n\
+/DrawCellTextOld {\n\
+ /cellHeight exch def\n\
+ /cellWidth exch def\n\
+ /justify exch def\n\
+ /yoffset exch def\n\
+ /xoffset exch def\n\
+ /spacing exch def\n\
+ /strings exch def\n\
+\n\
+ % Compute the baseline offset and the actual font height.\n\
+\n\
+ 0 0 moveto (TXygqPZ) false charpath\n\
+ pathbbox dup /baseline exch def\n\
+ exch pop exch sub /height exch def pop\n\
+ newpath\n\
+\n\
+ % Translate coordinates first so that the origin is at the upper-left\n\
+ % corner of the text's bounding box. Remember that x and y for\n\
+ % positioning are still on the stack.\n\
+\n\
+ translate\n\
+ cellWidth xoffset mul\n\
+ strings length 1 sub spacing mul height add yoffset mul translate\n\
+\n\
+ % Now use the baseline and justification information to translate so\n\
+ % that the origin is at the baseline and positioning point for the\n\
+ % first line of text.\n\
+\n\
+ justify cellWidth mul baseline neg translate\n\
+\n\
+ % Iterate over each of the lines to output it. For each line,\n\
+ % compute its width again so it can be properly justified, then\n\
+ % display it.\n\
+\n\
+ strings {\n\
+ dup stringwidth pop\n\
+ justify neg mul 0 moveto\n\
+ show\n\
+ 0 spacing neg translate\n\
+ } forall\n\
+} bind def\n\
+\n\
+%%EndProlog\n\
+",
+ /* End of part 5 */
+
+ NULL /* End of data marker */
+};
+
+/*
+ * Forward declarations for procedures defined later in this file:
+ */
+
+static int GetPostscriptPoints _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, double *doublePtr));
+int Tk_TablePsFont _ANSI_ARGS_((Tcl_Interp *interp,
+ Table *tablePtr, Tk_Font tkfont));
+int Tk_TablePsColor _ANSI_ARGS_((Tcl_Interp *interp,
+ Table *tablePtr, XColor *colorPtr));
+static int TextToPostscript _ANSI_ARGS_((Tcl_Interp *interp,
+ Table *tablePtr, TableTag *tagPtr, int tagX, int tagY,
+ int width, int height, int row, int col,
+ Tk_TextLayout textLayout));
+
+/*
+ * Tcl could really use some more convenience routines...
+ * This is just Tcl_DStringAppend for multiple lines, including
+ * the full text of each line
+ */
+void
+Tcl_DStringAppendAll TCL_VARARGS_DEF(Tcl_DString *, arg1)
+{
+ va_list argList;
+ Tcl_DString *dstringPtr;
+ char *string;
+
+ dstringPtr = TCL_VARARGS_START(Tcl_DString *, arg1, argList);
+ while ((string = va_arg(argList, char *)) != NULL) {
+ Tcl_DStringAppend(dstringPtr, string, -1);
+ }
+ va_end(argList);
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Table_PostscriptCmd --
+ *
+ * This procedure is invoked to process the "postscript" options
+ * of the widget command for table widgets. See the user
+ * documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *--------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+int
+Table_PostscriptCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Information about table widget. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of argument objects. */
+ Tcl_Obj *CONST objv[];
+{
+#ifdef _WIN32
+ /*
+ * At the moment, it just doesn't like this code...
+ */
+ return TCL_OK;
+#else
+ register Table *tablePtr = (Table *) clientData;
+ TkPostscriptInfo psInfo, *oldInfoPtr;
+ int result;
+ int row, col, firstRow, firstCol, lastRow, lastCol;
+ /* dimensions of first and last cell to output */
+ int x0, y0, w0, h0, xn, yn, wn, hn;
+ int x, y, w, h, i;
+#define STRING_LENGTH 400
+ char string[STRING_LENGTH+1], *p, **argv;
+ size_t length;
+ int deltaX = 0, deltaY = 0; /* Offset of lower-left corner of area to
+ * be marked up, measured in table units
+ * from the positioning point on the page
+ * (reflects anchor position). Initial
+ * values needed only to stop compiler
+ * warnings. */
+ Tcl_HashSearch search;
+ Tcl_HashEntry *hPtr;
+ CONST char * CONST *chunk;
+ Tk_TextLayout textLayout = NULL;
+ char *value;
+ int rowHeight, total, *colWidths, iW, iH;
+ TableTag *tagPtr, *colPtr, *rowPtr, *titlePtr;
+ Tcl_DString postscript, buffer;
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?option value ...?");
+ return TCL_ERROR;
+ }
+
+ /*
+ *----------------------------------------------------------------
+ * Initialize the data structure describing Postscript generation,
+ * then process all the arguments to fill the data structure in.
+ *----------------------------------------------------------------
+ */
+
+ Tcl_DStringInit(&postscript);
+ Tcl_DStringInit(&buffer);
+ oldInfoPtr = tablePtr->psInfoPtr;
+ tablePtr->psInfoPtr = &psInfo;
+ /* This is where in the window that we start printing from */
+ psInfo.x = 0;
+ psInfo.y = 0;
+ psInfo.width = -1;
+ psInfo.height = -1;
+ psInfo.pageXString = NULL;
+ psInfo.pageYString = NULL;
+ psInfo.pageX = 72*4.25;
+ psInfo.pageY = 72*5.5;
+ psInfo.pageWidthString = NULL;
+ psInfo.pageHeightString = NULL;
+ psInfo.scale = 1.0;
+ psInfo.pageAnchor = TK_ANCHOR_CENTER;
+ psInfo.rotate = 0;
+ psInfo.fontVar = NULL;
+ psInfo.colorVar = NULL;
+ psInfo.colorMode = NULL;
+ psInfo.colorLevel = 0;
+ psInfo.fileName = NULL;
+ psInfo.channelName = NULL;
+ psInfo.chan = NULL;
+ psInfo.first = NULL;
+ psInfo.last = NULL;
+ Tcl_InitHashTable(&psInfo.fontTable, TCL_STRING_KEYS);
+
+ /*
+ * The magic StringifyObjects
+ */
+ argv = (char **) ckalloc((objc + 1) * sizeof(char *));
+ for (i = 0; i < objc; i++)
+ argv[i] = Tcl_GetString(objv[i]);
+ argv[i] = NULL;
+
+ result = Tk_ConfigureWidget(interp, tablePtr->tkwin, configSpecs,
+ objc-2, argv+2, (char *) &psInfo,
+ TK_CONFIG_ARGV_ONLY);
+ if (result != TCL_OK) {
+ goto cleanup;
+ }
+
+ if (psInfo.first == NULL) {
+ firstRow = 0;
+ firstCol = 0;
+ } else if (TableGetIndex(tablePtr, psInfo.first, &firstRow, &firstCol)
+ != TCL_OK) {
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+ if (psInfo.last == NULL) {
+ lastRow = tablePtr->rows-1;
+ lastCol = tablePtr->cols-1;
+ } else if (TableGetIndex(tablePtr, psInfo.last, &lastRow, &lastCol)
+ != TCL_OK) {
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+
+ if (psInfo.fileName != NULL) {
+ /* Check that -file and -channel are not both specified. */
+ if (psInfo.channelName != NULL) {
+ Tcl_AppendResult(interp, "can't specify both -file",
+ " and -channel", (char *) NULL);
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+
+ /*
+ * Check that we are not in a safe interpreter. If we are, disallow
+ * the -file specification.
+ */
+ if (Tcl_IsSafe(interp)) {
+ Tcl_AppendResult(interp, "can't specify -file in a",
+ " safe interpreter", (char *) NULL);
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+
+ p = Tcl_TranslateFileName(interp, psInfo.fileName, &buffer);
+ if (p == NULL) {
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+ psInfo.chan = Tcl_OpenFileChannel(interp, p, "w", 0666);
+ Tcl_DStringFree(&buffer);
+ Tcl_DStringInit(&buffer);
+ if (psInfo.chan == NULL) {
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+ }
+
+ if (psInfo.channelName != NULL) {
+ int mode;
+ /*
+ * Check that the channel is found in this interpreter and that it
+ * is open for writing.
+ */
+ psInfo.chan = Tcl_GetChannel(interp, psInfo.channelName, &mode);
+ if (psInfo.chan == (Tcl_Channel) NULL) {
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+ if ((mode & TCL_WRITABLE) == 0) {
+ Tcl_AppendResult(interp, "channel \"", psInfo.channelName,
+ "\" wasn't opened for writing", (char *) NULL);
+ result = TCL_ERROR;
+ goto cleanup;
+ }
+ }
+
+ if (psInfo.colorMode == NULL) {
+ psInfo.colorLevel = 2;
+ } else {
+ length = strlen(psInfo.colorMode);
+ if (strncmp(psInfo.colorMode, "monochrome", length) == 0) {
+ psInfo.colorLevel = 0;
+ } else if (strncmp(psInfo.colorMode, "gray", length) == 0) {
+ psInfo.colorLevel = 1;
+ } else if (strncmp(psInfo.colorMode, "color", length) == 0) {
+ psInfo.colorLevel = 2;
+ } else {
+ Tcl_AppendResult(interp, "bad color mode \"", psInfo.colorMode,
+ "\": must be monochrome, gray or color", (char *) NULL);
+ goto cleanup;
+ }
+ }
+
+ TableCellCoords(tablePtr, firstRow, firstCol, &x0, &y0, &w0, &h0);
+ TableCellCoords(tablePtr, lastRow, lastCol, &xn, &yn, &wn, &hn);
+ psInfo.x = x0;
+ psInfo.y = y0;
+ if (psInfo.width == -1) {
+ psInfo.width = xn+wn;
+ }
+ if (psInfo.height == -1) {
+ psInfo.height = yn+hn;
+ }
+ psInfo.x2 = psInfo.x + psInfo.width;
+ psInfo.y2 = psInfo.y + psInfo.height;
+
+ if (psInfo.pageXString != NULL) {
+ if (GetPostscriptPoints(interp, psInfo.pageXString,
+ &psInfo.pageX) != TCL_OK) {
+ goto cleanup;
+ }
+ }
+ if (psInfo.pageYString != NULL) {
+ if (GetPostscriptPoints(interp, psInfo.pageYString,
+ &psInfo.pageY) != TCL_OK) {
+ goto cleanup;
+ }
+ }
+ if (psInfo.pageWidthString != NULL) {
+ if (GetPostscriptPoints(interp, psInfo.pageWidthString,
+ &psInfo.scale) != TCL_OK) {
+ goto cleanup;
+ }
+ psInfo.scale /= psInfo.width;
+ } else if (psInfo.pageHeightString != NULL) {
+ if (GetPostscriptPoints(interp, psInfo.pageHeightString,
+ &psInfo.scale) != TCL_OK) {
+ goto cleanup;
+ }
+ psInfo.scale /= psInfo.height;
+ } else {
+ psInfo.scale = (72.0/25.4)*WidthMMOfScreen(Tk_Screen(tablePtr->tkwin))
+ / WidthOfScreen(Tk_Screen(tablePtr->tkwin));
+ }
+ switch (psInfo.pageAnchor) {
+ case TK_ANCHOR_NW:
+ case TK_ANCHOR_W:
+ case TK_ANCHOR_SW:
+ deltaX = 0;
+ break;
+ case TK_ANCHOR_N:
+ case TK_ANCHOR_CENTER:
+ case TK_ANCHOR_S:
+ deltaX = -psInfo.width/2;
+ break;
+ case TK_ANCHOR_NE:
+ case TK_ANCHOR_E:
+ case TK_ANCHOR_SE:
+ deltaX = -psInfo.width;
+ break;
+ }
+ switch (psInfo.pageAnchor) {
+ case TK_ANCHOR_NW:
+ case TK_ANCHOR_N:
+ case TK_ANCHOR_NE:
+ deltaY = - psInfo.height;
+ break;
+ case TK_ANCHOR_W:
+ case TK_ANCHOR_CENTER:
+ case TK_ANCHOR_E:
+ deltaY = -psInfo.height/2;
+ break;
+ case TK_ANCHOR_SW:
+ case TK_ANCHOR_S:
+ case TK_ANCHOR_SE:
+ deltaY = 0;
+ break;
+ }
+
+ /*
+ *--------------------------------------------------------
+ * Make a PREPASS over all of the tags
+ * to collect information about all the fonts in use, so that
+ * we can output font information in the proper form required
+ * by the Document Structuring Conventions.
+ *--------------------------------------------------------
+ */
+
+ Tk_TablePsFont(interp, tablePtr, tablePtr->defaultTag.tkfont);
+ Tcl_ResetResult(interp);
+ for (hPtr = Tcl_FirstHashEntry(tablePtr->tagTable, &search);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ tagPtr = (TableTag *) Tcl_GetHashValue(hPtr);
+ if (tagPtr->tkfont != NULL) {
+ Tk_TablePsFont(interp, tablePtr, tagPtr->tkfont);
+ }
+ }
+ Tcl_ResetResult(interp);
+
+ /*
+ *--------------------------------------------------------
+ * Generate the header and prolog for the Postscript.
+ *--------------------------------------------------------
+ */
+
+ sprintf(string, " %d,%d => %d,%d\n", firstRow, firstCol, lastRow, lastCol);
+ Tcl_DStringAppendAll(&postscript,
+ "%!PS-Adobe-3.0 EPSF-3.0\n",
+ "%%Creator: Tk Table Widget ", TBL_VERSION, "\n",
+ "%%Title: Window ",
+ Tk_PathName(tablePtr->tkwin), string,
+ "%%BoundingBox: ",
+ (char *) NULL);
+ if (!psInfo.rotate) {
+ sprintf(string, "%d %d %d %d\n",
+ (int) (psInfo.pageX + psInfo.scale*deltaX),
+ (int) (psInfo.pageY + psInfo.scale*deltaY),
+ (int) (psInfo.pageX + psInfo.scale*(deltaX + psInfo.width)
+ + 1.0),
+ (int) (psInfo.pageY + psInfo.scale*(deltaY + psInfo.height)
+ + 1.0));
+ } else {
+ sprintf(string, "%d %d %d %d\n",
+ (int) (psInfo.pageX - psInfo.scale*(deltaY + psInfo.height)),
+ (int) (psInfo.pageY + psInfo.scale*deltaX),
+ (int) (psInfo.pageX - psInfo.scale*deltaY + 1.0),
+ (int) (psInfo.pageY + psInfo.scale*(deltaX + psInfo.width)
+ + 1.0));
+ }
+ Tcl_DStringAppendAll(&postscript, string,
+ "%%Pages: 1\n%%DocumentData: Clean7Bit\n",
+ "%%Orientation: ",
+ psInfo.rotate?"Landscape\n":"Portrait\n",
+ (char *) NULL);
+ p = "%%DocumentNeededResources: font ";
+ for (hPtr = Tcl_FirstHashEntry(&psInfo.fontTable, &search);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ sprintf(string, "%s%s\n", p, Tcl_GetHashKey(&psInfo.fontTable, hPtr));
+ Tcl_DStringAppend(&postscript, string, -1);
+ p = "%%+ font ";
+ }
+ Tcl_DStringAppend(&postscript, "%%EndComments\n\n", -1);
+
+ /*
+ * Insert the prolog
+ */
+ for (chunk=prolog; *chunk; chunk++) {
+ Tcl_DStringAppend(&postscript, *chunk, -1);
+ }
+
+ if (psInfo.chan != NULL) {
+ Tcl_Write(psInfo.chan, Tcl_DStringValue(&postscript), -1);
+ Tcl_DStringFree(&postscript);
+ Tcl_DStringInit(&postscript);
+ }
+
+ /*
+ * Document setup: set the color level and include fonts.
+ * This is where we start using &postscript
+ */
+
+ sprintf(string, "/CL %d def\n", psInfo.colorLevel);
+ Tcl_DStringAppendAll(&postscript, "%%BeginSetup\n", string, (char *) NULL);
+ for (hPtr = Tcl_FirstHashEntry(&psInfo.fontTable, &search);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ sprintf(string, "%s%s\n", "%%IncludeResource: font ",
+ Tcl_GetHashKey(&psInfo.fontTable, hPtr));
+ Tcl_DStringAppend(&postscript, string, -1);
+ }
+ Tcl_DStringAppend(&postscript, "%%EndSetup\n\n", -1);
+
+ /*
+ * Page setup: move to page positioning point, rotate if
+ * needed, set scale factor, offset for proper anchor position,
+ * and set clip region.
+ */
+
+ sprintf(string, "%.1f %.1f translate\n",
+ psInfo.pageX, psInfo.pageY);
+ Tcl_DStringAppendAll(&postscript, "%%Page: 1 1\nsave\n",
+ string, psInfo.rotate?"90 rotate\n":"",
+ (char *) NULL);
+ sprintf(string, "%.4g %.4g scale\n%d %d translate\n",
+ psInfo.scale, psInfo.scale, deltaX - psInfo.x, deltaY);
+ Tcl_DStringAppend(&postscript, string, -1);
+ sprintf(string, "%d %.15g moveto %d %.15g lineto %d %.15g lineto %d %.15g",
+ psInfo.x, (double) psInfo.y2-psInfo.y,
+ psInfo.x2,(double) psInfo.y2-psInfo.y,
+ psInfo.x2, 0.0, psInfo.x, 0.0);
+ Tcl_DStringAppend(&postscript, string, -1);
+ Tcl_DStringAppend(&postscript, " lineto closepath clip newpath\n", -1);
+ if (psInfo.chan != NULL) {
+ Tcl_Write(psInfo.chan, Tcl_DStringValue(&postscript), -1);
+ Tcl_DStringFree(&postscript);
+ Tcl_DStringInit(&postscript);
+ }
+
+ /*
+ * Go through each cell, calculating full desired height
+ */
+ result = TCL_OK;
+
+ hPtr = Tcl_FindHashEntry(tablePtr->tagTable, "title");
+ titlePtr = (TableTag *) Tcl_GetHashValue(hPtr);
+
+ total = 0;
+ colWidths = (int *) ckalloc((lastCol-firstCol) * sizeof(int));
+ for (col = 0; col <= lastCol-firstCol; col++) colWidths[col] = 0;
+ Tcl_DStringAppend(&buffer, "gsave\n", -1);
+ for (row = firstRow; row <= lastRow; row++) {
+ rowHeight = 0;
+ rowPtr = FindRowColTag(tablePtr, row+tablePtr->rowOffset, ROW);
+ for (col = firstCol; col <= lastCol; col++) {
+ /* get the coordinates for the cell */
+ TableCellCoords(tablePtr, row, col, &x, &y, &w, &h);
+ if ((x >= psInfo.x2) || (x+w < psInfo.x) ||
+ (y >= psInfo.y2) || (y+h < psInfo.y)) {
+ continue;
+ }
+
+ if (row == tablePtr->activeRow && col == tablePtr->activeCol) {
+ value = tablePtr->activeBuf;
+ } else {
+ value = TableGetCellValue(tablePtr, row+tablePtr->rowOffset,
+ col+tablePtr->colOffset);
+ }
+ if (!strlen(value)) {
+ continue;
+ }
+
+ /* Create the tag here */
+ tagPtr = TableNewTag();
+ /* First, merge in the default tag */
+ TableMergeTag(tagPtr, &(tablePtr->defaultTag));
+
+ colPtr = FindRowColTag(tablePtr, col+tablePtr->colOffset, COL);
+ if (colPtr != (TableTag *) NULL) TableMergeTag(tagPtr, colPtr);
+ if (rowPtr != (TableTag *) NULL) TableMergeTag(tagPtr, rowPtr);
+ /* Am I in the titles */
+ if (row < tablePtr->topRow || col < tablePtr->leftCol) {
+ TableMergeTag(tagPtr, titlePtr);
+ }
+ /* Does this have a cell tag */
+ TableMakeArrayIndex(row+tablePtr->rowOffset,
+ col+tablePtr->colOffset, string);
+ hPtr = Tcl_FindHashEntry(tablePtr->cellStyles, string);
+ if (hPtr != NULL) {
+ TableMergeTag(tagPtr, (TableTag *) Tcl_GetHashValue(hPtr));
+ }
+
+ /*
+ * the use of -1 instead of Tcl_NumUtfChars means we don't
+ * pass NULLs to postscript
+ */
+ textLayout = Tk_ComputeTextLayout(tagPtr->tkfont, value, -1,
+ (tagPtr->wrap>0) ? w : 0,
+ tagPtr->justify,
+ (tagPtr->multiline>0) ? 0 :
+ TK_IGNORE_NEWLINES, &iW, &iH);
+
+ rowHeight = MAX(rowHeight, iH);
+ colWidths[col-firstCol] = MAX(colWidths[col-firstCol], iW);
+
+ result = TextToPostscript(interp, tablePtr, tagPtr,
+ x, y, iW, iH, row, col, textLayout);
+ Tk_FreeTextLayout(textLayout);
+ if (result != TCL_OK) {
+ char msg[64 + TCL_INTEGER_SPACE];
+
+ sprintf(msg, "\n (generating Postscript for cell %s)",
+ string);
+ Tcl_AddErrorInfo(interp, msg);
+ goto cleanup;
+ }
+ Tcl_DStringAppend(&buffer, Tcl_GetStringResult(interp), -1);
+ }
+ sprintf(string, "/row%d %d def\n",
+ row, tablePtr->psInfoPtr->y2 - total);
+ Tcl_DStringAppend(&postscript, string, -1);
+ total += rowHeight + 2*tablePtr->defaultTag.bd;
+ }
+ Tcl_DStringAppend(&buffer, "grestore\n", -1);
+ sprintf(string, "/row%d %d def\n", row, tablePtr->psInfoPtr->y2 - total);
+ Tcl_DStringAppend(&postscript, string, -1);
+
+ total = tablePtr->defaultTag.bd;
+ for (col = firstCol; col <= lastCol; col++) {
+ sprintf(string, "/col%d %d def\n", col, total);
+ Tcl_DStringAppend(&postscript, string, -1);
+ total += colWidths[col-firstCol] + 2*tablePtr->defaultTag.bd;
+ }
+ sprintf(string, "/col%d %d def\n", col, total);
+ Tcl_DStringAppend(&postscript, string, -1);
+
+ Tcl_DStringAppend(&postscript, Tcl_DStringValue(&buffer), -1);
+
+ /*
+ * Output to channel at the end of it all
+ * This should more incremental, but that can't be avoided in order
+ * to post-define width/height of the cols/rows
+ */
+ if (psInfo.chan != NULL) {
+ Tcl_Write(psInfo.chan, Tcl_DStringValue(&postscript), -1);
+ Tcl_DStringFree(&postscript);
+ Tcl_DStringInit(&postscript);
+ }
+
+ /*
+ *---------------------------------------------------------------------
+ * Output page-end information, such as commands to print the page
+ * and document trailer stuff.
+ *---------------------------------------------------------------------
+ */
+
+ Tcl_DStringAppend(&postscript,
+ "restore showpage\n\n%%Trailer\nend\n%%EOF\n", -1);
+ if (psInfo.chan != NULL) {
+ Tcl_Write(psInfo.chan, Tcl_DStringValue(&postscript), -1);
+ Tcl_DStringFree(&postscript);
+ Tcl_DStringInit(&postscript);
+ }
+
+ /*
+ * Clean up psInfo to release malloc'ed stuff.
+ */
+
+cleanup:
+ ckfree((char *) argv);
+ Tcl_DStringResult(interp, &postscript);
+ Tcl_DStringFree(&postscript);
+ Tcl_DStringFree(&buffer);
+ if (psInfo.first != NULL) {
+ ckfree(psInfo.first);
+ }
+ if (psInfo.last != NULL) {
+ ckfree(psInfo.last);
+ }
+ if (psInfo.pageXString != NULL) {
+ ckfree(psInfo.pageXString);
+ }
+ if (psInfo.pageYString != NULL) {
+ ckfree(psInfo.pageYString);
+ }
+ if (psInfo.pageWidthString != NULL) {
+ ckfree(psInfo.pageWidthString);
+ }
+ if (psInfo.pageHeightString != NULL) {
+ ckfree(psInfo.pageHeightString);
+ }
+ if (psInfo.fontVar != NULL) {
+ ckfree(psInfo.fontVar);
+ }
+ if (psInfo.colorVar != NULL) {
+ ckfree(psInfo.colorVar);
+ }
+ if (psInfo.colorMode != NULL) {
+ ckfree(psInfo.colorMode);
+ }
+ if (psInfo.fileName != NULL) {
+ ckfree(psInfo.fileName);
+ }
+ if ((psInfo.chan != NULL) && (psInfo.channelName == NULL)) {
+ Tcl_Close(interp, psInfo.chan);
+ }
+ if (psInfo.channelName != NULL) {
+ ckfree(psInfo.channelName);
+ }
+ Tcl_DeleteHashTable(&psInfo.fontTable);
+ tablePtr->psInfoPtr = oldInfoPtr;
+ return result;
+#endif
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_TablePsColor --
+ *
+ * This procedure is called by individual table items when
+ * they want to set a color value for output. Given information
+ * about an X color, this procedure will generate Postscript
+ * commands to set up an appropriate color in Postscript.
+ *
+ * Results:
+ * Returns a standard Tcl return value. If an error occurs
+ * then an error message will be left in the interp's result.
+ * If no error occurs, then additional Postscript will be
+ * appended to the interp's result.
+ *
+ * Side effects:
+ * None.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tk_TablePsColor(interp, tablePtr, colorPtr)
+ Tcl_Interp *interp; /* Interpreter for returning Postscript
+ * or error message. */
+ Table *tablePtr; /* Information about table. */
+ XColor *colorPtr; /* Information about color. */
+{
+ TkPostscriptInfo *psInfoPtr = tablePtr->psInfoPtr;
+ int tmp;
+ double red, green, blue;
+ char string[200];
+
+ /*
+ * If there is a color map defined, then look up the color's name
+ * in the map and use the Postscript commands found there, if there
+ * are any.
+ */
+
+ if (psInfoPtr->colorVar != NULL) {
+ char *cmdString;
+
+ cmdString = Tcl_GetVar2(interp, psInfoPtr->colorVar,
+ Tk_NameOfColor(colorPtr), 0);
+ if (cmdString != NULL) {
+ Tcl_AppendResult(interp, cmdString, "\n", (char *) NULL);
+ return TCL_OK;
+ }
+ }
+
+ /*
+ * No color map entry for this color. Grab the color's intensities
+ * and output Postscript commands for them. Special note: X uses
+ * a range of 0-65535 for intensities, but most displays only use
+ * a range of 0-255, which maps to (0, 256, 512, ... 65280) in the
+ * X scale. This means that there's no way to get perfect white,
+ * since the highest intensity is only 65280 out of 65535. To
+ * work around this problem, rescale the X intensity to a 0-255
+ * scale and use that as the basis for the Postscript colors. This
+ * scheme still won't work if the display only uses 4 bits per color,
+ * but most diplays use at least 8 bits.
+ */
+
+ tmp = colorPtr->red;
+ red = ((double) (tmp >> 8))/255.0;
+ tmp = colorPtr->green;
+ green = ((double) (tmp >> 8))/255.0;
+ tmp = colorPtr->blue;
+ blue = ((double) (tmp >> 8))/255.0;
+ sprintf(string, "%.3f %.3f %.3f AdjustColor\n",
+ red, green, blue);
+ Tcl_AppendResult(interp, string, (char *) NULL);
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * Tk_TablePsFont --
+ *
+ * This procedure is called by individual table items when
+ * they want to output text. Given information about an X
+ * font, this procedure will generate Postscript commands
+ * to set up an appropriate font in Postscript.
+ *
+ * Results:
+ * Returns a standard Tcl return value. If an error occurs
+ * then an error message will be left in the interp's result.
+ * If no error occurs, then additional Postscript will be
+ * appended to the interp's result.
+ *
+ * Side effects:
+ * The Postscript font name is entered into psInfoPtr->fontTable
+ * if it wasn't already there.
+ *
+ *--------------------------------------------------------------
+ */
+
+int
+Tk_TablePsFont(interp, tablePtr, tkfont)
+ Tcl_Interp *interp; /* Interpreter for returning Postscript
+ * or error message. */
+ Table *tablePtr; /* Information about table. */
+ Tk_Font tkfont; /* Information about font in which text
+ * is to be printed. */
+{
+ TkPostscriptInfo *psInfoPtr = tablePtr->psInfoPtr;
+ char *end;
+ char pointString[TCL_INTEGER_SPACE];
+ Tcl_DString ds;
+ int i, points;
+
+ /*
+ * First, look up the font's name in the font map, if there is one.
+ * If there is an entry for this font, it consists of a list
+ * containing font name and size. Use this information.
+ */
+
+ Tcl_DStringInit(&ds);
+
+ if (psInfoPtr->fontVar != NULL) {
+ char *list, **argv;
+ int objc;
+ double size;
+ char *name;
+
+ name = Tk_NameOfFont(tkfont);
+ list = Tcl_GetVar2(interp, psInfoPtr->fontVar, name, 0);
+ if (list != NULL) {
+ if (Tcl_SplitList(interp, list, &objc, &argv) != TCL_OK) {
+ badMapEntry:
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "bad font map entry for \"", name,
+ "\": \"", list, "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ if (objc != 2) {
+ goto badMapEntry;
+ }
+ size = strtod(argv[1], &end);
+ if ((size <= 0) || (*end != 0)) {
+ goto badMapEntry;
+ }
+
+ Tcl_DStringAppend(&ds, argv[0], -1);
+ points = (int) size;
+
+ ckfree((char *) argv);
+ goto findfont;
+ }
+ }
+
+ points = Tk_PostscriptFontName(tkfont, &ds);
+
+findfont:
+ sprintf(pointString, "%d", points);
+ Tcl_AppendResult(interp, pointString, " /", Tcl_DStringValue(&ds),
+ " SetFont\n", (char *) NULL);
+ Tcl_CreateHashEntry(&psInfoPtr->fontTable, Tcl_DStringValue(&ds), &i);
+ Tcl_DStringFree(&ds);
+
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * GetPostscriptPoints --
+ *
+ * Given a string, returns the number of Postscript points
+ * corresponding to that string.
+ *
+ * Results:
+ * The return value is a standard Tcl return result. If
+ * TCL_OK is returned, then everything went well and the
+ * screen distance is stored at *doublePtr; otherwise
+ * TCL_ERROR is returned and an error message is left in
+ * the interp's result.
+ *
+ * Side effects:
+ * None.
+ *
+ *--------------------------------------------------------------
+ */
+
+static int
+GetPostscriptPoints(interp, string, doublePtr)
+ Tcl_Interp *interp; /* Use this for error reporting. */
+ char *string; /* String describing a screen distance. */
+ double *doublePtr; /* Place to store converted result. */
+{
+ char *end;
+ double d;
+
+ d = strtod(string, &end);
+ if (end == string) {
+ error:
+ Tcl_AppendResult(interp, "bad distance \"", string,
+ "\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+#define UCHAR(c) ((unsigned char) (c))
+ while ((*end != '\0') && isspace(UCHAR(*end))) {
+ end++;
+ }
+ switch (*end) {
+ case 'c':
+ d *= 72.0/2.54;
+ end++;
+ break;
+ case 'i':
+ d *= 72.0;
+ end++;
+ break;
+ case 'm':
+ d *= 72.0/25.4;
+ end++;
+ break;
+ case 0:
+ break;
+ case 'p':
+ end++;
+ break;
+ default:
+ goto error;
+ }
+ while ((*end != '\0') && isspace(UCHAR(*end))) {
+ end++;
+ }
+ if (*end != 0) {
+ goto error;
+ }
+ *doublePtr = d;
+ return TCL_OK;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * TextToPostscript --
+ *
+ * This procedure is called to generate Postscript for
+ * text items.
+ *
+ * Results:
+ * The return value is a standard Tcl result. If an error
+ * occurs in generating Postscript then an error message is
+ * left in the interp's result, replacing whatever used
+ * to be there. If no error occurs, then Postscript for the
+ * item is appended to the result.
+ *
+ * Side effects:
+ * None.
+ *
+ *--------------------------------------------------------------
+ */
+
+static int
+TextToPostscript(interp, tablePtr, tagPtr, tagX, tagY, width, height,
+ row, col, textLayout)
+ Tcl_Interp *interp; /* Leave Postscript or error message here. */
+ Table *tablePtr; /* Information about overall canvas. */
+ TableTag *tagPtr; /* */
+ int tagX, tagY; /* */
+ int width, height; /* */
+ int row, col; /* */
+ Tk_TextLayout textLayout; /* */
+{
+ int x, y;
+ Tk_FontMetrics fm;
+ char *justify;
+ char buffer[500];
+ Tk_3DBorder fg = tagPtr->fg;
+
+ if (fg == NULL) {
+ fg = tablePtr->defaultTag.fg;
+ }
+
+ if (Tk_TablePsFont(interp, tablePtr, tagPtr->tkfont) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (Tk_TablePsColor(interp, tablePtr, Tk_3DBorderColor(fg)) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ sprintf(buffer, "%% %.15g %.15g [\n", (tagX+width)/2.0,
+ tablePtr->psInfoPtr->y2 - ((tagY+height)/2.0));
+ Tcl_AppendResult(interp, buffer, (char *) NULL);
+ sprintf(buffer, "col%d row%d [\n", col, row);
+ Tcl_AppendResult(interp, buffer, (char *) NULL);
+
+ Tk_TextLayoutToPostscript(interp, textLayout);
+
+ x = 0; y = 0; justify = NULL; /* lint. */
+ switch (tagPtr->anchor) {
+ case TK_ANCHOR_NW: x = 0; y = 0; break;
+ case TK_ANCHOR_N: x = 1; y = 0; break;
+ case TK_ANCHOR_NE: x = 2; y = 0; break;
+ case TK_ANCHOR_E: x = 2; y = 1; break;
+ case TK_ANCHOR_SE: x = 2; y = 2; break;
+ case TK_ANCHOR_S: x = 1; y = 2; break;
+ case TK_ANCHOR_SW: x = 0; y = 2; break;
+ case TK_ANCHOR_W: x = 0; y = 1; break;
+ case TK_ANCHOR_CENTER: x = 1; y = 1; break;
+ }
+ switch (tagPtr->justify) {
+ case TK_JUSTIFY_RIGHT: justify = "1"; break;
+ case TK_JUSTIFY_CENTER: justify = "0.5";break;
+ case TK_JUSTIFY_LEFT: justify = "0";
+ }
+
+ Tk_GetFontMetrics(tagPtr->tkfont, &fm);
+ sprintf(buffer, "] %d %g %g %s %d %d DrawCellText\n",
+ fm.linespace, (x / -2.0), (y / 2.0), justify,
+ width, height);
+ Tcl_AppendResult(interp, buffer, (char *) NULL);
+
+ return TCL_OK;
+}
diff --git a/libgui/src/tkTableUtil.c b/libgui/src/tkTableUtil.c
new file mode 100644
index 00000000000..29e2f143456
--- /dev/null
+++ b/libgui/src/tkTableUtil.c
@@ -0,0 +1,340 @@
+/*
+ * tkTableUtil.c --
+ *
+ * This module contains utility functions for table widgets.
+ *
+ * Copyright (c) 2000 Jeffrey Hobbs
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * RCS: @(#) $Id$
+ */
+
+#include "tkTable.h"
+
+static char * Cmd_GetName _ANSI_ARGS_((const Cmd_Struct *cmds, int val));
+static int Cmd_GetValue _ANSI_ARGS_((const Cmd_Struct *cmds,
+ const char *arg));
+static void Cmd_GetError _ANSI_ARGS_((Tcl_Interp *interp,
+ const Cmd_Struct *cmds, const char *arg));
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TableOptionBdSet --
+ *
+ * This routine configures the borderwidth value for a tag.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * It may adjust the tag struct values of bd[0..4] and borders.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TableOptionBdSet(clientData, interp, tkwin, value, widgRec, offset)
+ ClientData clientData; /* Type of struct being set. */
+ Tcl_Interp *interp; /* Used for reporting errors. */
+ Tk_Window tkwin; /* Window containing table widget. */
+ char *value; /* Value of option. */
+ char *widgRec; /* Pointer to record for item. */
+ int offset; /* Offset into item. */
+{
+ char **borderStr;
+ int *bordersPtr, *bdPtr;
+ int type = (int) clientData;
+ int result = TCL_OK;
+ int argc;
+ char **argv;
+
+
+ if ((type == BD_TABLE) && (value[0] == '\0')) {
+ /*
+ * NULL strings aren't allowed for the table global -bd
+ */
+ Tcl_AppendResult(interp, "borderwidth value may not be empty",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ if ((type == BD_TABLE) || (type == BD_TABLE_TAG)) {
+ TableTag *tagPtr = (TableTag *) (widgRec + offset);
+ borderStr = &(tagPtr->borderStr);
+ bordersPtr = &(tagPtr->borders);
+ bdPtr = tagPtr->bd;
+ } else if (type == BD_TABLE_WIN) {
+ TableEmbWindow *tagPtr = (TableEmbWindow *) widgRec;
+ borderStr = &(tagPtr->borderStr);
+ bordersPtr = &(tagPtr->borders);
+ bdPtr = tagPtr->bd;
+ } else {
+ panic("invalid type given to TableOptionBdSet\n");
+ return TCL_ERROR; /* lint */
+ }
+
+ result = Tcl_SplitList(interp, value, &argc, &argv);
+ if (result == TCL_OK) {
+ int i, bd[4];
+
+ if (((type == BD_TABLE) && (argc == 0)) || (argc == 3) || (argc > 4)) {
+ Tcl_AppendResult(interp,
+ "1, 2 or 4 values must be specified for borderwidth",
+ (char *) NULL);
+ result = TCL_ERROR;
+ } else {
+ /*
+ * We use the shadow bd array first, in case we have an error
+ * parsing arguments half way through.
+ */
+ for (i = 0; i < argc; i++) {
+ if (Tk_GetPixels(interp, tkwin, argv[i], &(bd[i])) != TCL_OK) {
+ result = TCL_ERROR;
+ break;
+ }
+ }
+ /*
+ * If everything is OK, store the parsed and given values for
+ * easy retrieval.
+ */
+ if (result == TCL_OK) {
+ for (i = 0; i < argc; i++) {
+ bdPtr[i] = MAX(0, bd[i]);
+ }
+ if (*borderStr) {
+ ckfree(*borderStr);
+ }
+ if (value) {
+ *borderStr = (char *) ckalloc(strlen(value) + 1);
+ strcpy(*borderStr, value);
+ } else {
+ *borderStr = NULL;
+ }
+ *bordersPtr = argc;
+ }
+ }
+ ckfree ((char *) argv);
+ }
+
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TableOptionBdGet --
+ *
+ * Results:
+ * Value of the -bd option.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TableOptionBdGet(clientData, tkwin, widgRec, offset, freeProcPtr)
+ ClientData clientData; /* Type of struct being set. */
+ Tk_Window tkwin; /* Window containing canvas widget. */
+ char *widgRec; /* Pointer to record for item. */
+ int offset; /* Offset into item. */
+ Tcl_FreeProc **freeProcPtr; /* Pointer to variable to fill in with
+ * information about how to reclaim
+ * storage for return string. */
+{
+ register int type = (int) clientData;
+
+ if (type == BD_TABLE) {
+ return ((TableTag *) (widgRec + offset))->borderStr;
+ } else if (type == BD_TABLE_TAG) {
+ return ((TableTag *) widgRec)->borderStr;
+ } else if (type == BD_TABLE_WIN) {
+ return ((TableEmbWindow *) widgRec)->borderStr;
+ } else {
+ panic("invalid type given to TableOptionBdSet\n");
+ return NULL; /* lint */
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TableTagConfigureBd --
+ * This routine configures the border values based on a tag.
+ * The previous value of the bd string (oldValue) is assumed to
+ * be a valid value for this tag.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * It may adjust the value used by -bd.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TableTagConfigureBd(Table *tablePtr, TableTag *tagPtr,
+ char *oldValue, int nullOK)
+{
+ int i, argc, result = TCL_OK;
+ char **argv;
+
+ /*
+ * First check to see if the value really changed.
+ */
+ if (strcmp(tagPtr->borderStr ? tagPtr->borderStr : "",
+ oldValue ? oldValue : "") == 0) {
+ return TCL_OK;
+ }
+
+ tagPtr->borders = 0;
+ if (!nullOK && ((tagPtr->borderStr == NULL)
+ || (*(tagPtr->borderStr) == '\0'))) {
+ /*
+ * NULL strings aren't allowed for this tag
+ */
+ result = TCL_ERROR;
+ } else if (tagPtr->borderStr) {
+ result = Tcl_SplitList(tablePtr->interp, tagPtr->borderStr,
+ &argc, &argv);
+ if (result == TCL_OK) {
+ if ((!nullOK && (argc == 0)) || (argc == 3) || (argc > 4)) {
+ Tcl_SetResult(tablePtr->interp,
+ "1, 2 or 4 values must be specified to -borderwidth",
+ TCL_STATIC);
+ result = TCL_ERROR;
+ } else {
+ for (i = 0; i < argc; i++) {
+ if (Tk_GetPixels(tablePtr->interp, tablePtr->tkwin,
+ argv[i], &(tagPtr->bd[i])) != TCL_OK) {
+ result = TCL_ERROR;
+ break;
+ }
+ tagPtr->bd[i] = MAX(0, tagPtr->bd[i]);
+ }
+ tagPtr->borders = argc;
+ }
+ ckfree ((char *) argv);
+ }
+ }
+
+ if (result != TCL_OK) {
+ if (tagPtr->borderStr) {
+ ckfree ((char *) tagPtr->borderStr);
+ }
+ if (oldValue != NULL) {
+ size_t length = strlen(oldValue) + 1;
+ /*
+ * We are making the assumption that oldValue is correct.
+ * We have to reparse in case the bad new value had a couple
+ * of correct args before failing on a bad pixel value.
+ */
+ Tcl_SplitList(tablePtr->interp, oldValue, &argc, &argv);
+ for (i = 0; i < argc; i++) {
+ Tk_GetPixels(tablePtr->interp, tablePtr->tkwin,
+ argv[i], &(tagPtr->bd[i]));
+ }
+ ckfree ((char *) argv);
+ tagPtr->borders = argc;
+ tagPtr->borderStr = (char *) ckalloc(length);
+ memcpy(tagPtr->borderStr, oldValue, length);
+ } else {
+ tagPtr->borders = 0;
+ tagPtr->borderStr = (char *) NULL;
+ }
+ }
+
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Cmd_OptionSet --
+ *
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Cmd_OptionSet(ClientData clientData, Tcl_Interp *interp,
+ Tk_Window unused, char *value, char *widgRec, int offset)
+{
+ Cmd_Struct *p = (Cmd_Struct *)clientData;
+ int mode = Cmd_GetValue(p,value);
+ if (!mode) {
+ Cmd_GetError(interp,p,value);
+ return TCL_ERROR;
+ }
+ *((int*)(widgRec+offset)) = mode;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Cmd_OptionGet --
+ *
+ *
+ * Results:
+ * Value of the option.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+Cmd_OptionGet(ClientData clientData, Tk_Window unused,
+ char *widgRec, int offset, Tcl_FreeProc **freeProcPtr)
+{
+ Cmd_Struct *p = (Cmd_Struct *)clientData;
+ int mode = *((int*)(widgRec+offset));
+ return Cmd_GetName(p,mode);
+}
+
+/*
+ * simple Cmd_Struct lookup functions
+ */
+
+char *
+Cmd_GetName(const Cmd_Struct *cmds, int val)
+{
+ for(;cmds->name && cmds->name[0];cmds++) {
+ if (cmds->value==val) return cmds->name;
+ }
+ return NULL;
+}
+
+int
+Cmd_GetValue(const Cmd_Struct *cmds, const char *arg)
+{
+ unsigned int len = strlen(arg);
+ for(;cmds->name && cmds->name[0];cmds++) {
+ if (!strncmp(cmds->name, arg, len)) return cmds->value;
+ }
+ return 0;
+}
+
+void
+Cmd_GetError(Tcl_Interp *interp, const Cmd_Struct *cmds, const char *arg)
+{
+ int i;
+ Tcl_AppendResult(interp, "bad option \"", arg, "\" must be ", (char *) 0);
+ for(i=0;cmds->name && cmds->name[0];cmds++,i++) {
+ Tcl_AppendResult(interp, (i?", ":""), cmds->name, (char *) 0);
+ }
+}
diff --git a/libgui/src/tkWinPrintCanvas.c b/libgui/src/tkWinPrintCanvas.c
index 5b7bc41830a..029c6687f52 100644
--- a/libgui/src/tkWinPrintCanvas.c
+++ b/libgui/src/tkWinPrintCanvas.c
@@ -52,20 +52,20 @@ PrintCanvasCmd(clientData, interp, argc, argv)
int tiles_wide,tiles_high;
int tile_y, tile_x;
int screenX1, screenX2, screenY1, screenY2, width, height;
- DOCINFO *lpdi = malloc(sizeof(DOCINFO));
+ DOCINFO *lpdi = (DOCINFO *) ckalloc(sizeof(DOCINFO));
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " canvas \"",
(char *) NULL);
- return TCL_ERROR;
+ goto error;
}
/* The second arg is the canvas widget */
if (!Tcl_GetCommandInfo(interp, argv[1], &canvCmd)) {
Tcl_AppendResult(interp, "couldn't get canvas information for \"",
argv[1], "\"", (char *) NULL);
- return TCL_ERROR;
+ goto error;
}
memset(&dm,0,sizeof(DEVMODE));
@@ -74,7 +74,7 @@ PrintCanvasCmd(clientData, interp, argc, argv)
memset(lpdi,0,sizeof(DOCINFO));
lpdi->cbSize=sizeof(DOCINFO);
- lpdi->lpszDocName=malloc(255);
+ lpdi->lpszDocName= (LPCSTR) ckalloc(255);
sprintf((char*)lpdi->lpszDocName,"SN - Printing\0");
lpdi->lpszOutput=NULL;
@@ -164,8 +164,12 @@ PrintCanvasCmd(clientData, interp, argc, argv)
EndDoc(pd.hDC);
done:
+ ckfree ((char*) lpdi->lpszDocName);
+ ckfree ((char*) lpdi);
return TCL_OK;
- error:
+error:
+ ckfree ((char*) lpdi->lpszDocName);
+ ckfree ((char*) lpdi);
return TCL_ERROR;
}
diff --git a/libgui/src/tkWinPrintText.c b/libgui/src/tkWinPrintText.c
index a9ffd36bfb9..88ed8b8884d 100644
--- a/libgui/src/tkWinPrintText.c
+++ b/libgui/src/tkWinPrintText.c
@@ -212,7 +212,8 @@ typedef struct TextStyle {
-void DisplayDLineToDrawable(TkText *textPtr, DLine *dlPtr, DLine *prevPtr, TkWinDrawable *drawable);
+static void
+DisplayDLineToDrawable(TkText *textPtr, DLine *dlPtr, DLine *prevPtr, TkWinDrawable *drawable);
/*
*--------------------------------------------------------------
@@ -248,7 +249,7 @@ PrintTextCmd(clientData, interp, argc, argv)
Pixmap pixmap;
int bottomY = 0; /* Initialization needed only to stop
* compiler warnings. */
- DOCINFO *lpdi = malloc(sizeof(DOCINFO));
+ DOCINFO *lpdi = (DOCINFO *) ckalloc(sizeof(DOCINFO));
TkTextIndex first, last;
int numLines;
HDC hDCpixmap;
@@ -272,7 +273,7 @@ PrintTextCmd(clientData, interp, argc, argv)
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " text \"",
(char *) NULL);
- return TCL_ERROR;
+ goto error;
}
/*
@@ -281,7 +282,7 @@ PrintTextCmd(clientData, interp, argc, argv)
if (!Tcl_GetCommandInfo(interp, argv[1], &textCmd)) {
Tcl_AppendResult(interp, "couldn't get text information for \"",
argv[1], "\"", (char *) NULL);
- return TCL_ERROR;
+ goto error;
}
memset(&dm,0,sizeof(DEVMODE));
@@ -290,7 +291,7 @@ PrintTextCmd(clientData, interp, argc, argv)
memset(lpdi,0,sizeof(DOCINFO));
lpdi->cbSize=sizeof(DOCINFO);
- lpdi->lpszDocName=malloc(255);
+ lpdi->lpszDocName = (LPCSTR) ckalloc(255);
sprintf((char*)lpdi->lpszDocName,"SN - Printing\0");
lpdi->lpszOutput=NULL;
@@ -445,8 +446,12 @@ PrintTextCmd(clientData, interp, argc, argv)
textPtr->dInfoPtr->flags|=DINFO_OUT_OF_DATE;
done:
+ ckfree ((char*) lpdi->lpszDocName);
+ ckfree ((char*) lpdi);
return TCL_OK;
- error:
+error:
+ ckfree ((char*) lpdi->lpszDocName);
+ ckfree ((char*) lpdi);
return TCL_ERROR;
}
View Lorry Controller Status