--- to_be_filed/sf_code/esrgpcpj/shared/tk_base/tklistbox.c 2016/10/08 07:08:47 29 +++ projs/ets/trunk/src/c_tk_base_7_5_w_mods/tklistbox.c 2018/07/22 15:58:07 220 @@ -1,3295 +1,3287 @@ -/* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tk_base/tklistbox.c,v 1.1.1.1 2001/06/13 05:05:02 dtashley Exp $ */ - -/* - * tkListbox.c -- - * - * This module implements listbox widgets for the Tk - * toolkit. A listbox displays a collection of strings, - * one per line, and provides scrolling and selection. - * - * Copyright (c) 1990-1994 The Regents of the University of California. - * Copyright (c) 1994-1997 Sun Microsystems, Inc. - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tklistbox.c,v 1.1.1.1 2001/06/13 05:05:02 dtashley Exp $ - */ - -#include "tkPort.h" -#include "default.h" -#include "tkInt.h" - -typedef struct { - Tk_OptionTable listboxOptionTable; /* Table defining configuration options - * available for the listbox */ - Tk_OptionTable itemAttrOptionTable; /* Table definining configuration - * options available for listbox - * items */ -} ListboxOptionTables; - -/* - * A data structure of the following type is kept for each listbox - * widget managed by this file: - */ - -typedef struct { - Tk_Window tkwin; /* Window that embodies the listbox. NULL - * means that the window has been destroyed - * but the data structures haven't yet been - * cleaned up.*/ - Display *display; /* Display containing widget. Used, among - * other things, so that resources can be - * freed even after tkwin has gone away. */ - Tcl_Interp *interp; /* Interpreter associated with listbox. */ - Tcl_Command widgetCmd; /* Token for listbox's widget command. */ - Tk_OptionTable optionTable; /* Table that defines configuration options - * available for this widget. */ - Tk_OptionTable itemAttrOptionTable; /* Table that defines configuration - * options available for listbox - * items */ - char *listVarName; /* List variable name */ - Tcl_Obj *listObj; /* Pointer to the list object being used */ - int nElements; /* Holds the current count of elements */ - Tcl_HashTable *selection; /* Tracks selection */ - Tcl_HashTable *itemAttrTable; /* Tracks item attributes */ - - /* - * Information used when displaying widget: - */ - - Tk_3DBorder normalBorder; /* Used for drawing border around whole - * window, plus used for background. */ - int borderWidth; /* Width of 3-D border around window. */ - int relief; /* 3-D effect: TK_RELIEF_RAISED, etc. */ - int highlightWidth; /* Width in pixels of highlight to draw - * around widget when it has the focus. - * <= 0 means don't draw a highlight. */ - XColor *highlightBgColorPtr; - /* Color for drawing traversal highlight - * area when highlight is off. */ - XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ - int inset; /* Total width of all borders, including - * traversal highlight and 3-D border. - * Indicates how much interior stuff must - * be offset from outside edges to leave - * room for borders. */ - Tk_Font tkfont; /* Information about text font, or NULL. */ - XColor *fgColorPtr; /* Text color in normal mode. */ - GC textGC; /* For drawing normal text. */ - Tk_3DBorder selBorder; /* Borders and backgrounds for selected - * elements. */ - int selBorderWidth; /* Width of border around selection. */ - XColor *selFgColorPtr; /* Foreground color for selected elements. */ - GC selTextGC; /* For drawing selected text. */ - int width; /* Desired width of window, in characters. */ - int height; /* Desired height of window, in lines. */ - int lineHeight; /* Number of pixels allocated for each line - * in display. */ - int topIndex; /* Index of top-most element visible in - * window. */ - int fullLines; /* Number of lines that fit are completely - * visible in window. There may be one - * additional line at the bottom that is - * partially visible. */ - int partialLine; /* 0 means that the window holds exactly - * fullLines lines. 1 means that there is - * one additional line that is partially - * visble. */ - int setGrid; /* Non-zero means pass gridding information - * to window manager. */ - - /* - * Information to support horizontal scrolling: - */ - - int maxWidth; /* Width (in pixels) of widest string in - * listbox. */ - int xScrollUnit; /* Number of pixels in one "unit" for - * horizontal scrolling (window scrolls - * horizontally in increments of this size). - * This is an average character size. */ - int xOffset; /* The left edge of each string in the - * listbox is offset to the left by this - * many pixels (0 means no offset, positive - * means there is an offset). */ - - /* - * Information about what's selected or active, if any. - */ - - Tk_Uid selectMode; /* Selection style: single, browse, multiple, - * or extended. This value isn't used in C - * code, but the Tcl bindings use it. */ - int numSelected; /* Number of elements currently selected. */ - int selectAnchor; /* Fixed end of selection (i.e. element - * at which selection was started.) */ - int exportSelection; /* Non-zero means tie internal listbox - * to X selection. */ - int active; /* Index of "active" element (the one that - * has been selected by keyboard traversal). - * -1 means none. */ - - /* - * Information for scanning: - */ - - int scanMarkX; /* X-position at which scan started (e.g. - * button was pressed here). */ - int scanMarkY; /* Y-position at which scan started (e.g. - * button was pressed here). */ - int scanMarkXOffset; /* Value of "xOffset" field when scan - * started. */ - int scanMarkYIndex; /* Index of line that was at top of window - * when scan started. */ - - /* - * Miscellaneous information: - */ - - Tk_Cursor cursor; /* Current cursor for window, or None. */ - char *takeFocus; /* Value of -takefocus option; not used in - * the C code, but used by keyboard traversal - * scripts. Malloc'ed, but may be NULL. */ - char *yScrollCmd; /* Command prefix for communicating with - * vertical scrollbar. NULL means no command - * to issue. Malloc'ed. */ - char *xScrollCmd; /* Command prefix for communicating with - * horizontal scrollbar. NULL means no command - * to issue. Malloc'ed. */ - int flags; /* Various flag bits: see below for - * definitions. */ -} Listbox; - -/* - * ItemAttr structures are used to store item configuration information for - * the items in a listbox - */ -typedef struct { - Tk_3DBorder border; /* Used for drawing background around text */ - Tk_3DBorder selBorder; /* Used for selected text */ - XColor *fgColor; /* Text color in normal mode. */ - XColor *selFgColor; /* Text color in selected mode. */ -} ItemAttr; - -/* - * Flag bits for listboxes: - * - * REDRAW_PENDING: Non-zero means a DoWhenIdle handler - * has already been queued to redraw - * this window. - * UPDATE_V_SCROLLBAR: Non-zero means vertical scrollbar needs - * to be updated. - * UPDATE_H_SCROLLBAR: Non-zero means horizontal scrollbar needs - * to be updated. - * GOT_FOCUS: Non-zero means this widget currently - * has the input focus. - * MAXWIDTH_IS_STALE: Stored maxWidth may be out-of-date - * LISTBOX_DELETED: This listbox has been effectively destroyed. - */ - -#define REDRAW_PENDING 1 -#define UPDATE_V_SCROLLBAR 2 -#define UPDATE_H_SCROLLBAR 4 -#define GOT_FOCUS 8 -#define MAXWIDTH_IS_STALE 16 -#define LISTBOX_DELETED 32 - -/* - * The optionSpecs table defines the valid configuration options for the - * listbox widget - */ -static Tk_OptionSpec optionSpecs[] = { - {TK_OPTION_BORDER, "-background", "background", "Background", - DEF_LISTBOX_BG_COLOR, -1, Tk_Offset(Listbox, normalBorder), - 0, (ClientData) DEF_LISTBOX_BG_MONO, 0}, - {TK_OPTION_SYNONYM, "-bd", (char *) NULL, (char *) NULL, - (char *) NULL, 0, -1, 0, (ClientData) "-borderwidth", 0}, - {TK_OPTION_SYNONYM, "-bg", (char *) NULL, (char *) NULL, - (char *) NULL, 0, -1, 0, (ClientData) "-background", 0}, - {TK_OPTION_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", - DEF_LISTBOX_BORDER_WIDTH, -1, Tk_Offset(Listbox, borderWidth), - 0, 0, 0}, - {TK_OPTION_CURSOR, "-cursor", "cursor", "Cursor", - DEF_LISTBOX_CURSOR, -1, Tk_Offset(Listbox, cursor), - TK_OPTION_NULL_OK, 0, 0}, - {TK_OPTION_BOOLEAN, "-exportselection", "exportSelection", - "ExportSelection", DEF_LISTBOX_EXPORT_SELECTION, -1, - Tk_Offset(Listbox, exportSelection), 0, 0, 0}, - {TK_OPTION_SYNONYM, "-fg", "foreground", (char *) NULL, - (char *) NULL, 0, -1, 0, (ClientData) "-foreground", 0}, - {TK_OPTION_FONT, "-font", "font", "Font", - DEF_LISTBOX_FONT, -1, Tk_Offset(Listbox, tkfont), 0, 0, 0}, - {TK_OPTION_COLOR, "-foreground", "foreground", "Foreground", - DEF_LISTBOX_FG, -1, Tk_Offset(Listbox, fgColorPtr), 0, 0, 0}, - {TK_OPTION_INT, "-height", "height", "Height", - DEF_LISTBOX_HEIGHT, -1, Tk_Offset(Listbox, height), 0, 0, 0}, - {TK_OPTION_COLOR, "-highlightbackground", "highlightBackground", - "HighlightBackground", DEF_LISTBOX_HIGHLIGHT_BG, -1, - Tk_Offset(Listbox, highlightBgColorPtr), 0, 0, 0}, - {TK_OPTION_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", - DEF_LISTBOX_HIGHLIGHT, -1, Tk_Offset(Listbox, highlightColorPtr), - 0, 0, 0}, - {TK_OPTION_PIXELS, "-highlightthickness", "highlightThickness", - "HighlightThickness", DEF_LISTBOX_HIGHLIGHT_WIDTH, -1, - Tk_Offset(Listbox, highlightWidth), 0, 0, 0}, - {TK_OPTION_RELIEF, "-relief", "relief", "Relief", - DEF_LISTBOX_RELIEF, -1, Tk_Offset(Listbox, relief), 0, 0, 0}, - {TK_OPTION_BORDER, "-selectbackground", "selectBackground", "Foreground", - DEF_LISTBOX_SELECT_COLOR, -1, Tk_Offset(Listbox, selBorder), - 0, (ClientData) DEF_LISTBOX_SELECT_MONO, 0}, - {TK_OPTION_PIXELS, "-selectborderwidth", "selectBorderWidth", - "BorderWidth", DEF_LISTBOX_SELECT_BD, -1, - Tk_Offset(Listbox, selBorderWidth), 0, 0, 0}, - {TK_OPTION_COLOR, "-selectforeground", "selectForeground", "Background", - DEF_LISTBOX_SELECT_FG_COLOR, -1, Tk_Offset(Listbox, selFgColorPtr), - 0, (ClientData) DEF_LISTBOX_SELECT_FG_MONO, 0}, - {TK_OPTION_STRING, "-selectmode", "selectMode", "SelectMode", - DEF_LISTBOX_SELECT_MODE, -1, Tk_Offset(Listbox, selectMode), - TK_OPTION_NULL_OK, 0, 0}, - {TK_OPTION_BOOLEAN, "-setgrid", "setGrid", "SetGrid", - DEF_LISTBOX_SET_GRID, -1, Tk_Offset(Listbox, setGrid), 0, 0, 0}, - {TK_OPTION_STRING, "-takefocus", "takeFocus", "TakeFocus", - DEF_LISTBOX_TAKE_FOCUS, -1, Tk_Offset(Listbox, takeFocus), - TK_OPTION_NULL_OK, 0, 0}, - {TK_OPTION_INT, "-width", "width", "Width", - DEF_LISTBOX_WIDTH, -1, Tk_Offset(Listbox, width), 0, 0, 0}, - {TK_OPTION_STRING, "-xscrollcommand", "xScrollCommand", "ScrollCommand", - DEF_LISTBOX_SCROLL_COMMAND, -1, Tk_Offset(Listbox, xScrollCmd), - TK_OPTION_NULL_OK, 0, 0}, - {TK_OPTION_STRING, "-yscrollcommand", "yScrollCommand", "ScrollCommand", - DEF_LISTBOX_SCROLL_COMMAND, -1, Tk_Offset(Listbox, yScrollCmd), - TK_OPTION_NULL_OK, 0, 0}, - {TK_OPTION_STRING, "-listvariable", "listVariable", "Variable", - DEF_LISTBOX_LIST_VARIABLE, -1, Tk_Offset(Listbox, listVarName), - TK_OPTION_NULL_OK, 0, 0}, - {TK_OPTION_END, (char *) NULL, (char *) NULL, (char *) NULL, - (char *) NULL, 0, -1, 0, 0, 0} -}; - -/* - * The itemAttrOptionSpecs table defines the valid configuration options for - * listbox items - */ -static Tk_OptionSpec itemAttrOptionSpecs[] = { - {TK_OPTION_BORDER, "-background", "background", "Background", - (char *)NULL, -1, Tk_Offset(ItemAttr, border), - TK_OPTION_NULL_OK|TK_OPTION_DONT_SET_DEFAULT, - (ClientData) DEF_LISTBOX_BG_MONO, 0}, - {TK_OPTION_SYNONYM, "-bg", (char *) NULL, (char *) NULL, - (char *) NULL, 0, -1, 0, (ClientData) "-background", 0}, - {TK_OPTION_SYNONYM, "-fg", "foreground", (char *) NULL, - (char *) NULL, 0, -1, 0, (ClientData) "-foreground", 0}, - {TK_OPTION_COLOR, "-foreground", "foreground", "Foreground", - (char *) NULL, -1, Tk_Offset(ItemAttr, fgColor), - TK_OPTION_NULL_OK|TK_OPTION_DONT_SET_DEFAULT, 0, 0}, - {TK_OPTION_BORDER, "-selectbackground", "selectBackground", "Foreground", - (char *) NULL, -1, Tk_Offset(ItemAttr, selBorder), - TK_OPTION_NULL_OK|TK_OPTION_DONT_SET_DEFAULT, - (ClientData) DEF_LISTBOX_SELECT_MONO, 0}, - {TK_OPTION_COLOR, "-selectforeground", "selectForeground", "Background", - (char *) NULL, -1, Tk_Offset(ItemAttr, selFgColor), - TK_OPTION_NULL_OK|TK_OPTION_DONT_SET_DEFAULT, - (ClientData) DEF_LISTBOX_SELECT_FG_MONO, 0}, - {TK_OPTION_END, (char *) NULL, (char *) NULL, (char *) NULL, - (char *) NULL, 0, -1, 0, 0, 0} -}; - -/* - * The following tables define the listbox widget commands (and sub- - * commands) and map the indexes into the string tables into - * enumerated types used to dispatch the listbox widget command. - */ -static char *commandNames[] = { - "activate", "bbox", "cget", "configure", "curselection", "delete", "get", - "index", "insert", "itemcget", "itemconfigure", "nearest", "scan", - "see", "selection", "size", "xview", "yview", - (char *) NULL -}; - -enum command { - COMMAND_ACTIVATE, COMMAND_BBOX, COMMAND_CGET, COMMAND_CONFIGURE, - COMMAND_CURSELECTION, COMMAND_DELETE, COMMAND_GET, COMMAND_INDEX, - COMMAND_INSERT, COMMAND_ITEMCGET, COMMAND_ITEMCONFIGURE, - COMMAND_NEAREST, COMMAND_SCAN, COMMAND_SEE, COMMAND_SELECTION, - COMMAND_SIZE, COMMAND_XVIEW, COMMAND_YVIEW -}; - -static char *selCommandNames[] = { - "anchor", "clear", "includes", "set", (char *) NULL -}; - -enum selcommand { - SELECTION_ANCHOR, SELECTION_CLEAR, SELECTION_INCLUDES, SELECTION_SET -}; - -static char *scanCommandNames[] = { - "mark", "dragto", (char *) NULL -}; - -enum scancommand { - SCAN_MARK, SCAN_DRAGTO -}; - -static char *indexNames[] = { - "active", "anchor", "end", (char *)NULL -}; - -enum indices { - INDEX_ACTIVE, INDEX_ANCHOR, INDEX_END -}; - - -/* Declarations for procedures defined later in this file */ -static void ChangeListboxOffset _ANSI_ARGS_((Listbox *listPtr, - int offset)); -static void ChangeListboxView _ANSI_ARGS_((Listbox *listPtr, - int index)); -static int ConfigureListbox _ANSI_ARGS_((Tcl_Interp *interp, - Listbox *listPtr, int objc, Tcl_Obj *CONST objv[], - int flags)); -static int ConfigureListboxItem _ANSI_ARGS_ ((Tcl_Interp *interp, - Listbox *listPtr, ItemAttr *attrs, int objc, - Tcl_Obj *CONST objv[])); -static int ListboxDeleteSubCmd _ANSI_ARGS_((Listbox *listPtr, - int first, int last)); -static void DestroyListbox _ANSI_ARGS_((char *memPtr)); -static void DestroyListboxOptionTables _ANSI_ARGS_ ( - (ClientData clientData, Tcl_Interp *interp)); -static void DisplayListbox _ANSI_ARGS_((ClientData clientData)); -static int GetListboxIndex _ANSI_ARGS_((Tcl_Interp *interp, - Listbox *listPtr, Tcl_Obj *index, int endIsSize, - int *indexPtr)); -static int ListboxInsertSubCmd _ANSI_ARGS_((Listbox *listPtr, - int index, int objc, Tcl_Obj *CONST objv[])); -static void ListboxCmdDeletedProc _ANSI_ARGS_(( - ClientData clientData)); -static void ListboxComputeGeometry _ANSI_ARGS_((Listbox *listPtr, - int fontChanged, int maxIsStale, int updateGrid)); -static void ListboxEventProc _ANSI_ARGS_((ClientData clientData, - XEvent *eventPtr)); -static int ListboxFetchSelection _ANSI_ARGS_(( - ClientData clientData, int offset, char *buffer, - int maxBytes)); -static void ListboxLostSelection _ANSI_ARGS_(( - ClientData clientData)); -static void EventuallyRedrawRange _ANSI_ARGS_((Listbox *listPtr, - int first, int last)); -static void ListboxScanTo _ANSI_ARGS_((Listbox *listPtr, - int x, int y)); -static int ListboxSelect _ANSI_ARGS_((Listbox *listPtr, - int first, int last, int select)); -static void ListboxUpdateHScrollbar _ANSI_ARGS_( - (Listbox *listPtr)); -static void ListboxUpdateVScrollbar _ANSI_ARGS_( - (Listbox *listPtr)); -static int ListboxWidgetObjCmd _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[])); -static int ListboxBboxSubCmd _ANSI_ARGS_ ((Tcl_Interp *interp, - Listbox *listPtr, int index)); -static int ListboxSelectionSubCmd _ANSI_ARGS_ ( - (Tcl_Interp *interp, Listbox *listPtr, int objc, - Tcl_Obj *CONST objv[])); -static int ListboxXviewSubCmd _ANSI_ARGS_ ((Tcl_Interp *interp, - Listbox *listPtr, int objc, - Tcl_Obj *CONST objv[])); -static int ListboxYviewSubCmd _ANSI_ARGS_ ((Tcl_Interp *interp, - Listbox *listPtr, int objc, - Tcl_Obj *CONST objv[])); -static ItemAttr * ListboxGetItemAttributes _ANSI_ARGS_ ( - (Tcl_Interp *interp, Listbox *listPtr, int index)); -static void ListboxWorldChanged _ANSI_ARGS_(( - ClientData instanceData)); -static int NearestListboxElement _ANSI_ARGS_((Listbox *listPtr, - int y)); -static char * ListboxListVarProc _ANSI_ARGS_ ((ClientData clientData, - Tcl_Interp *interp, char *name1, char *name2, - int flags)); -static void MigrateHashEntries _ANSI_ARGS_ ((Tcl_HashTable *table, - int first, int last, int offset)); -/* - * The structure below defines button class behavior by means of procedures - * that can be invoked from generic window code. - */ - -static TkClassProcs listboxClass = { - NULL, /* createProc. */ - ListboxWorldChanged, /* geometryProc. */ - NULL /* modalProc. */ -}; - - -/* - *-------------------------------------------------------------- - * - * Tk_ListboxObjCmd -- - * - * This procedure is invoked to process the "listbox" Tcl - * command. See the user documentation for details on what - * it does. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * See the user documentation. - * - *-------------------------------------------------------------- - */ - -int -Tk_ListboxObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Either NULL or pointer to option table */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ -{ - register Listbox *listPtr; - Tk_Window tkwin; - ListboxOptionTables *optionTables; - - optionTables = (ListboxOptionTables *)clientData; - if (optionTables == NULL) { - Tcl_CmdInfo info; - char *name; - - /* - * We haven't created the option tables for this widget class yet. - * Do it now and save the a pointer to them as the ClientData for - * the command, so future invocations will have access to it. - */ - optionTables = - (ListboxOptionTables *) ckalloc(sizeof(ListboxOptionTables)); - /* Set up an exit handler to free the optionTables struct */ - Tcl_SetAssocData(interp, "ListboxOptionTables", - DestroyListboxOptionTables, (ClientData) optionTables); - - /* Create the listbox option table and the listbox item option table */ - optionTables->listboxOptionTable = - Tk_CreateOptionTable(interp, optionSpecs); - optionTables->itemAttrOptionTable = - Tk_CreateOptionTable(interp, itemAttrOptionSpecs); - - /* Store a pointer to the tables as the ClientData for the command */ - name = Tcl_GetString(objv[0]); - Tcl_GetCommandInfo(interp, name, &info); - info.objClientData = (ClientData) optionTables; - Tcl_SetCommandInfo(interp, name, &info); - } - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "pathName ?options?"); - return TCL_ERROR; - } - - tkwin = Tk_CreateWindowFromPath(interp, Tk_MainWindow(interp), - Tcl_GetString(objv[1]), (char *) NULL); - if (tkwin == NULL) { - return TCL_ERROR; - } - - /* - * Initialize the fields of the structure that won't be initialized - * by ConfigureListbox, or that ConfigureListbox requires to be - * initialized already (e.g. resource pointers). - */ - listPtr = (Listbox *) ckalloc(sizeof(Listbox)); - listPtr->tkwin = tkwin; - listPtr->display = Tk_Display(tkwin); - listPtr->interp = interp; - listPtr->widgetCmd = Tcl_CreateObjCommand(interp, - Tk_PathName(listPtr->tkwin), ListboxWidgetObjCmd, - (ClientData) listPtr, ListboxCmdDeletedProc); - listPtr->optionTable = optionTables->listboxOptionTable; - listPtr->itemAttrOptionTable = optionTables->itemAttrOptionTable; - listPtr->listVarName = NULL; - listPtr->listObj = NULL; - listPtr->selection = - (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(listPtr->selection, TCL_ONE_WORD_KEYS); - listPtr->itemAttrTable = - (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(listPtr->itemAttrTable, TCL_ONE_WORD_KEYS); - listPtr->nElements = 0; - listPtr->normalBorder = NULL; - listPtr->borderWidth = 0; - listPtr->relief = TK_RELIEF_RAISED; - listPtr->highlightWidth = 0; - listPtr->highlightBgColorPtr = NULL; - listPtr->highlightColorPtr = NULL; - listPtr->inset = 0; - listPtr->tkfont = NULL; - listPtr->fgColorPtr = NULL; - listPtr->textGC = None; - listPtr->selBorder = NULL; - listPtr->selBorderWidth = 0; - listPtr->selFgColorPtr = None; - listPtr->selTextGC = None; - listPtr->width = 0; - listPtr->height = 0; - listPtr->lineHeight = 0; - listPtr->topIndex = 0; - listPtr->fullLines = 1; - listPtr->partialLine = 0; - listPtr->setGrid = 0; - listPtr->maxWidth = 0; - listPtr->xScrollUnit = 1; - listPtr->xOffset = 0; - listPtr->selectMode = NULL; - listPtr->numSelected = 0; - listPtr->selectAnchor = 0; - listPtr->exportSelection = 1; - listPtr->active = 0; - listPtr->scanMarkX = 0; - listPtr->scanMarkY = 0; - listPtr->scanMarkXOffset = 0; - listPtr->scanMarkYIndex = 0; - listPtr->cursor = None; - listPtr->takeFocus = NULL; - listPtr->xScrollCmd = NULL; - listPtr->yScrollCmd = NULL; - listPtr->flags = 0; - - Tk_SetClass(listPtr->tkwin, "Listbox"); - TkSetClassProcs(listPtr->tkwin, &listboxClass, (ClientData) listPtr); - Tk_CreateEventHandler(listPtr->tkwin, - ExposureMask|StructureNotifyMask|FocusChangeMask, - ListboxEventProc, (ClientData) listPtr); - Tk_CreateSelHandler(listPtr->tkwin, XA_PRIMARY, XA_STRING, - ListboxFetchSelection, (ClientData) listPtr, XA_STRING); - if (Tk_InitOptions(interp, (char *)listPtr, - optionTables->listboxOptionTable, tkwin) != TCL_OK) { - Tk_DestroyWindow(listPtr->tkwin); - return TCL_ERROR; - } - - if (ConfigureListbox(interp, listPtr, objc-2, objv+2, 0) != TCL_OK) { - Tk_DestroyWindow(listPtr->tkwin); - return TCL_ERROR; - } - - Tcl_SetResult(interp, Tk_PathName(listPtr->tkwin), TCL_STATIC); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ListboxWidgetObjCmd -- - * - * This Tcl_Obj based procedure is invoked to process the Tcl command - * that corresponds to a 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. - * - *---------------------------------------------------------------------- - */ - -static int -ListboxWidgetObjCmd(clientData, interp, objc, objv) - ClientData clientData; /* Information about listbox widget. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Arguments as Tcl_Obj's. */ -{ - register Listbox *listPtr = (Listbox *) clientData; - int cmdIndex, index; - int result = TCL_OK; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); - return TCL_ERROR; - } - Tcl_Preserve((ClientData)listPtr); - - /* - * Parse the command by looking up the second argument in the list - * of valid subcommand names - */ - result = Tcl_GetIndexFromObj(interp, objv[1], commandNames, - "option", 0, &cmdIndex); - if (result != TCL_OK) { - Tcl_Release((ClientData)listPtr); - return result; - } - - /* The subcommand was valid, so continue processing */ - switch (cmdIndex) { - case COMMAND_ACTIVATE: { - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "index"); - result = TCL_ERROR; - break; - } - result = GetListboxIndex(interp, listPtr, objv[2], 0, &index); - if (result != TCL_OK) { - break; - } - if (index >= listPtr->nElements) { - index = listPtr->nElements-1; - } - if (index < 0) { - index = 0; - } - listPtr->active = index; - EventuallyRedrawRange(listPtr, listPtr->active, listPtr->active); - result = TCL_OK; - break; - } - - case COMMAND_BBOX: { - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "index"); - result = TCL_ERROR; - break; - } - result = GetListboxIndex(interp, listPtr, objv[2], 0, &index); - if (result != TCL_OK) { - break; - } - - result = ListboxBboxSubCmd(interp, listPtr, index); - break; - } - - case COMMAND_CGET: { - Tcl_Obj *objPtr; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "option"); - result = TCL_ERROR; - break; - } - - objPtr = Tk_GetOptionValue(interp, (char *)listPtr, - listPtr->optionTable, objv[2], listPtr->tkwin); - if (objPtr == NULL) { - result = TCL_ERROR; - break; - } - Tcl_SetObjResult(interp, objPtr); - result = TCL_OK; - break; - } - - case COMMAND_CONFIGURE: { - Tcl_Obj *objPtr; - if (objc <= 3) { - objPtr = Tk_GetOptionInfo(interp, (char *) listPtr, - listPtr->optionTable, - (objc == 3) ? objv[2] : (Tcl_Obj *) NULL, - listPtr->tkwin); - if (objPtr == NULL) { - result = TCL_ERROR; - break; - } else { - Tcl_SetObjResult(interp, objPtr); - result = TCL_OK; - } - } else { - result = ConfigureListbox(interp, listPtr, objc-2, objv+2, 0); - } - break; - } - - case COMMAND_CURSELECTION: { - char indexStringRep[TCL_INTEGER_SPACE]; - int i; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - result = TCL_ERROR; - break; - } - /* - * Of course, it would be more efficient to use the Tcl_HashTable - * search functions (Tcl_FirstHashEntry, Tcl_NextHashEntry), but - * then the result wouldn't be in sorted order. So instead we - * loop through the indices in order, adding them to the result - * if they are selected - */ - for (i = 0; i < listPtr->nElements; i++) { - if (Tcl_FindHashEntry(listPtr->selection, (char *)i) != NULL) { - sprintf(indexStringRep, "%d", i); - Tcl_AppendElement(interp, indexStringRep); - } - } - result = TCL_OK; - break; - } - - case COMMAND_DELETE: { - int first, last; - if ((objc < 3) || (objc > 4)) { - Tcl_WrongNumArgs(interp, 2, objv, - "firstIndex ?lastIndex?"); - result = TCL_ERROR; - break; - } - - result = GetListboxIndex(interp, listPtr, objv[2], 0, &first); - if (result != TCL_OK) { - break; - } - if (first < listPtr->nElements) { - /* - * if a "last index" was given, get it now; otherwise, use the - * first index as the last index - */ - if (objc == 4) { - result = GetListboxIndex(interp, listPtr, - objv[3], 0, &last); - if (result != TCL_OK) { - break; - } - } else { - last = first; - } - if (last >= listPtr->nElements) { - last = listPtr->nElements - 1; - } - result = ListboxDeleteSubCmd(listPtr, first, last); - } else { - result = TCL_OK; - } - break; - } - - case COMMAND_GET: { - int first, last; - Tcl_Obj **elemPtrs; - int listLen; - if (objc != 3 && objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "firstIndex ?lastIndex?"); - result = TCL_ERROR; - break; - } - result = GetListboxIndex(interp, listPtr, objv[2], 0, &first); - if (result != TCL_OK) { - break; - } - last = first; - if (objc == 4) { - result = GetListboxIndex(interp, listPtr, objv[3], 0, &last); - if (result != TCL_OK) { - break; - } - } - if (first >= listPtr->nElements) { - result = TCL_OK; - break; - } - if (last >= listPtr->nElements) { - last = listPtr->nElements - 1; - } - if (first < 0) { - first = 0; - } - if (first > last) { - result = TCL_OK; - break; - } - result = Tcl_ListObjGetElements(interp, listPtr->listObj, &listLen, - &elemPtrs); - if (result != TCL_OK) { - break; - } - if (objc == 3) { - /* - * One element request - we return a string - */ - Tcl_SetObjResult(interp, elemPtrs[first]); - } else { - Tcl_SetListObj(Tcl_GetObjResult(interp), (last - first + 1), - &(elemPtrs[first])); - } - result = TCL_OK; - break; - } - - case COMMAND_INDEX:{ - char buf[TCL_INTEGER_SPACE]; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "index"); - result = TCL_ERROR; - break; - } - result = GetListboxIndex(interp, listPtr, objv[2], 1, &index); - if (result != TCL_OK) { - break; - } - sprintf(buf, "%d", index); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - result = TCL_OK; - break; - } - - case COMMAND_INSERT: { - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, - "index ?element element ...?"); - result = TCL_ERROR; - break; - } - - result = GetListboxIndex(interp, listPtr, objv[2], 1, &index); - if (result != TCL_OK) { - break; - } - result = ListboxInsertSubCmd(listPtr, index, objc-3, objv+3); - break; - } - - case COMMAND_ITEMCGET: { - Tcl_Obj *objPtr; - ItemAttr *attrPtr; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 2, objv, "index option"); - result = TCL_ERROR; - break; - } - - result = GetListboxIndex(interp, listPtr, objv[2], 0, &index); - if (result != TCL_OK) { - break; - } - - if (index < 0 || index >= listPtr->nElements) { - Tcl_AppendResult(interp, "item number \"", - Tcl_GetString(objv[2]), "\" out of range", - (char *)NULL); - result = TCL_ERROR; - break; - } - - attrPtr = ListboxGetItemAttributes(interp, listPtr, index); - - objPtr = Tk_GetOptionValue(interp, (char *)attrPtr, - listPtr->itemAttrOptionTable, objv[3], listPtr->tkwin); - if (objPtr == NULL) { - result = TCL_ERROR; - break; - } - Tcl_SetObjResult(interp, objPtr); - result = TCL_OK; - break; - } - - case COMMAND_ITEMCONFIGURE: { - Tcl_Obj *objPtr; - ItemAttr *attrPtr; - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, - "index ?option? ?value? ?option value ...?"); - result = TCL_ERROR; - break; - } - - result = GetListboxIndex(interp, listPtr, objv[2], 0, &index); - if (result != TCL_OK) { - break; - } - - if (index < 0 || index >= listPtr->nElements) { - Tcl_AppendResult(interp, "item number \"", - Tcl_GetString(objv[2]), "\" out of range", - (char *)NULL); - result = TCL_ERROR; - break; - } - - attrPtr = ListboxGetItemAttributes(interp, listPtr, index); - if (objc <= 4) { - objPtr = Tk_GetOptionInfo(interp, (char *)attrPtr, - listPtr->itemAttrOptionTable, - (objc == 4) ? objv[3] : (Tcl_Obj *) NULL, - listPtr->tkwin); - if (objPtr == NULL) { - result = TCL_ERROR; - break; - } else { - Tcl_SetObjResult(interp, objPtr); - result = TCL_OK; - } - } else { - result = ConfigureListboxItem(interp, listPtr, attrPtr, - objc-3, objv+3); - } - break; - } - - case COMMAND_NEAREST: { - char buf[TCL_INTEGER_SPACE]; - int y; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "y"); - result = TCL_ERROR; - break; - } - - result = Tcl_GetIntFromObj(interp, objv[2], &y); - if (result != TCL_OK) { - break; - } - index = NearestListboxElement(listPtr, y); - sprintf(buf, "%d", index); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - result = TCL_OK; - break; - } - - case COMMAND_SCAN: { - int x, y, scanCmdIndex; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "mark|dragto x y"); - result = TCL_ERROR; - break; - } - - if (Tcl_GetIntFromObj(interp, objv[3], &x) != TCL_OK - || Tcl_GetIntFromObj(interp, objv[4], &y) != TCL_OK) { - result = TCL_ERROR; - break; - } - - result = Tcl_GetIndexFromObj(interp, objv[2], scanCommandNames, - "option", 0, &scanCmdIndex); - if (result != TCL_OK) { - break; - } - switch (scanCmdIndex) { - case SCAN_MARK: { - listPtr->scanMarkX = x; - listPtr->scanMarkY = y; - listPtr->scanMarkXOffset = listPtr->xOffset; - listPtr->scanMarkYIndex = listPtr->topIndex; - break; - } - case SCAN_DRAGTO: { - ListboxScanTo(listPtr, x, y); - break; - } - } - result = TCL_OK; - break; - } - - case COMMAND_SEE: { - int diff; - if (objc != 3) { - Tcl_WrongNumArgs(interp, 2, objv, "index"); - result = TCL_ERROR; - break; - } - result = GetListboxIndex(interp, listPtr, objv[2], 0, &index); - if (result != TCL_OK) { - break; - } - if (index >= listPtr->nElements) { - index = listPtr->nElements - 1; - } - if (index < 0) { - index = 0; - } - diff = listPtr->topIndex - index; - if (diff > 0) { - if (diff <= (listPtr->fullLines/3)) { - ChangeListboxView(listPtr, index); - } else { - ChangeListboxView(listPtr, - index - (listPtr->fullLines-1)/2); - } - } else { - diff = index - (listPtr->topIndex + listPtr->fullLines - 1); - if (diff > 0) { - if (diff <= (listPtr->fullLines/3)) { - ChangeListboxView(listPtr, listPtr->topIndex + diff); - } else { - ChangeListboxView(listPtr, - index - (listPtr->fullLines-1)/2); - } - } - } - result = TCL_OK; - break; - } - - case COMMAND_SELECTION: { - result = ListboxSelectionSubCmd(interp, listPtr, objc, objv); - break; - } - - case COMMAND_SIZE: { - char buf[TCL_INTEGER_SPACE]; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - result = TCL_ERROR; - break; - } - sprintf(buf, "%d", listPtr->nElements); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - result = TCL_OK; - break; - } - - case COMMAND_XVIEW: { - result = ListboxXviewSubCmd(interp, listPtr, objc, objv); - break; - } - - case COMMAND_YVIEW: { - result = ListboxYviewSubCmd(interp, listPtr, objc, objv); - break; - } - } - Tcl_Release((ClientData)listPtr); - return result; -} - -/* - *---------------------------------------------------------------------- - * - * ListboxBboxSubCmd -- - * - * This procedure is invoked to process a listbox bbox request. - * See the user documentation for more information. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * For valid indices, places the bbox of the requested element in - * the interpreter's result. - * - *---------------------------------------------------------------------- - */ - -static int -ListboxBboxSubCmd(interp, listPtr, index) - Tcl_Interp *interp; /* Pointer to the calling Tcl interpreter */ - Listbox *listPtr; /* Information about the listbox */ - int index; /* Index of the element to get bbox info on */ -{ - int lastVisibleIndex; - /* Determine the index of the last visible item in the listbox */ - lastVisibleIndex = listPtr->topIndex + listPtr->fullLines - + listPtr->partialLine; - if (listPtr->nElements < lastVisibleIndex) { - lastVisibleIndex = listPtr->nElements; - } - - /* Only allow bbox requests for indices that are visible */ - if ((listPtr->topIndex <= index) && (index < lastVisibleIndex)) { - char buf[TCL_INTEGER_SPACE * 4]; - Tcl_Obj *el; - char *stringRep; - int pixelWidth, stringLen, x, y, result; - Tk_FontMetrics fm; - - /* Compute the pixel width of the requested element */ - result = Tcl_ListObjIndex(interp, listPtr->listObj, index, &el); - if (result != TCL_OK) { - return result; - } - - stringRep = Tcl_GetStringFromObj(el, &stringLen); - Tk_GetFontMetrics(listPtr->tkfont, &fm); - pixelWidth = Tk_TextWidth(listPtr->tkfont, stringRep, stringLen); - - x = listPtr->inset + listPtr->selBorderWidth - listPtr->xOffset; - y = ((index - listPtr->topIndex)*listPtr->lineHeight) - + listPtr->inset + listPtr->selBorderWidth; - sprintf(buf, "%d %d %d %d", x, y, pixelWidth, fm.linespace); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ListboxSelectionSubCmd -- - * - * This procedure is invoked to process the selection sub command - * for listbox widgets. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * May set the interpreter's result field. - * - *---------------------------------------------------------------------- - */ - -static int -ListboxSelectionSubCmd(interp, listPtr, objc, objv) - Tcl_Interp *interp; /* Pointer to the calling Tcl interpreter */ - Listbox *listPtr; /* Information about the listbox */ - int objc; /* Number of arguments in the objv array */ - Tcl_Obj *CONST objv[]; /* Array of arguments to the procedure */ -{ - int selCmdIndex, first, last; - int result = TCL_OK; - if (objc != 4 && objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "option index ?index?"); - return TCL_ERROR; - } - result = GetListboxIndex(interp, listPtr, objv[3], 0, &first); - if (result != TCL_OK) { - return result; - } - last = first; - if (objc == 5) { - result = GetListboxIndex(interp, listPtr, objv[4], 0, &last); - if (result != TCL_OK) { - return result; - } - } - result = Tcl_GetIndexFromObj(interp, objv[2], selCommandNames, - "option", 0, &selCmdIndex); - if (result != TCL_OK) { - return result; - } - switch (selCmdIndex) { - case SELECTION_ANCHOR: { - if (objc != 4) { - Tcl_WrongNumArgs(interp, 3, objv, "index"); - return TCL_ERROR; - } - if (first >= listPtr->nElements) { - first = listPtr->nElements - 1; - } - if (first < 0) { - first = 0; - } - listPtr->selectAnchor = first; - result = TCL_OK; - break; - } - case SELECTION_CLEAR: { - result = ListboxSelect(listPtr, first, last, 0); - break; - } - case SELECTION_INCLUDES: { - if (objc != 4) { - Tcl_WrongNumArgs(interp, 3, objv, "index"); - return TCL_ERROR; - } - if (Tcl_FindHashEntry(listPtr->selection, (char *)first)) { - Tcl_SetResult(interp, "1", TCL_STATIC); - } else { - Tcl_SetResult(interp, "0", TCL_STATIC); - } - result = TCL_OK; - break; - } - case SELECTION_SET: { - result = ListboxSelect(listPtr, first, last, 1); - break; - } - } - return result; -} - -/* - *---------------------------------------------------------------------- - * - * ListboxXviewSubCmd -- - * - * Process the listbox "xview" subcommand. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * May change the listbox viewing area; may set the interpreter's result. - * - *---------------------------------------------------------------------- - */ - -static int -ListboxXviewSubCmd(interp, listPtr, objc, objv) - Tcl_Interp *interp; /* Pointer to the calling Tcl interpreter */ - Listbox *listPtr; /* Information about the listbox */ - int objc; /* Number of arguments in the objv array */ - Tcl_Obj *CONST objv[]; /* Array of arguments to the procedure */ -{ - - int index, count, type, windowWidth, windowUnits; - int offset = 0; /* Initialized to stop gcc warnings. */ - double fraction, fraction2; - - windowWidth = Tk_Width(listPtr->tkwin) - - 2*(listPtr->inset + listPtr->selBorderWidth); - if (objc == 2) { - if (listPtr->maxWidth == 0) { - Tcl_SetResult(interp, "0 1", TCL_STATIC); - } else { - char buf[TCL_DOUBLE_SPACE * 2]; - - fraction = listPtr->xOffset/((double) listPtr->maxWidth); - fraction2 = (listPtr->xOffset + windowWidth) - /((double) listPtr->maxWidth); - if (fraction2 > 1.0) { - fraction2 = 1.0; - } - sprintf(buf, "%g %g", fraction, fraction2); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } - } else if (objc == 3) { - if (Tcl_GetIntFromObj(interp, objv[2], &index) != TCL_OK) { - return TCL_ERROR; - } - ChangeListboxOffset(listPtr, index*listPtr->xScrollUnit); - } else { - type = Tk_GetScrollInfoObj(interp, objc, objv, &fraction, &count); - switch (type) { - case TK_SCROLL_ERROR: - return TCL_ERROR; - case TK_SCROLL_MOVETO: - offset = (int) (fraction*listPtr->maxWidth + 0.5); - break; - case TK_SCROLL_PAGES: - windowUnits = windowWidth/listPtr->xScrollUnit; - if (windowUnits > 2) { - offset = listPtr->xOffset - + count*listPtr->xScrollUnit*(windowUnits-2); - } else { - offset = listPtr->xOffset + count*listPtr->xScrollUnit; - } - break; - case TK_SCROLL_UNITS: - offset = listPtr->xOffset + count*listPtr->xScrollUnit; - break; - } - ChangeListboxOffset(listPtr, offset); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ListboxYviewSubCmd -- - * - * Process the listbox "yview" subcommand. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * May change the listbox viewing area; may set the interpreter's result. - * - *---------------------------------------------------------------------- - */ - -static int -ListboxYviewSubCmd(interp, listPtr, objc, objv) - Tcl_Interp *interp; /* Pointer to the calling Tcl interpreter */ - Listbox *listPtr; /* Information about the listbox */ - int objc; /* Number of arguments in the objv array */ - Tcl_Obj *CONST objv[]; /* Array of arguments to the procedure */ -{ - int index, count, type; - double fraction, fraction2; - - if (objc == 2) { - if (listPtr->nElements == 0) { - Tcl_SetResult(interp, "0 1", TCL_STATIC); - } else { - char buf[TCL_DOUBLE_SPACE * 2]; - - fraction = listPtr->topIndex/((double) listPtr->nElements); - fraction2 = (listPtr->topIndex+listPtr->fullLines) - /((double) listPtr->nElements); - if (fraction2 > 1.0) { - fraction2 = 1.0; - } - sprintf(buf, "%g %g", fraction, fraction2); - Tcl_SetResult(interp, buf, TCL_VOLATILE); - } - } else if (objc == 3) { - if (GetListboxIndex(interp, listPtr, objv[2], 0, &index) != TCL_OK) { - return TCL_ERROR; - } - ChangeListboxView(listPtr, index); - } else { - type = Tk_GetScrollInfoObj(interp, objc, objv, &fraction, &count); - switch (type) { - case TK_SCROLL_ERROR: - return TCL_ERROR; - case TK_SCROLL_MOVETO: - index = (int) (listPtr->nElements*fraction + 0.5); - break; - case TK_SCROLL_PAGES: - if (listPtr->fullLines > 2) { - index = listPtr->topIndex - + count*(listPtr->fullLines-2); - } else { - index = listPtr->topIndex + count; - } - break; - case TK_SCROLL_UNITS: - index = listPtr->topIndex + count; - break; - } - ChangeListboxView(listPtr, index); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ListboxGetItemAttributes -- - * - * Returns a pointer to the ItemAttr record for a given index, - * creating one if it does not already exist. - * - * Results: - * Pointer to an ItemAttr record. - * - * Side effects: - * Memory may be allocated for the ItemAttr record. - * - *---------------------------------------------------------------------- - */ - -static ItemAttr * -ListboxGetItemAttributes(interp, listPtr, index) - Tcl_Interp *interp; /* Pointer to the calling Tcl interpreter */ - Listbox *listPtr; /* Information about the listbox */ - int index; /* Index of the item to retrieve attributes - * for */ -{ - int new; - Tcl_HashEntry *entry; - ItemAttr *attrs; - - entry = Tcl_CreateHashEntry(listPtr->itemAttrTable, (char *)index, - &new); - if (new) { - attrs = (ItemAttr *) ckalloc(sizeof(ItemAttr)); - attrs->border = NULL; - attrs->selBorder = NULL; - attrs->fgColor = NULL; - attrs->selFgColor = NULL; - Tk_InitOptions(interp, (char *)attrs, listPtr->itemAttrOptionTable, - listPtr->tkwin); - Tcl_SetHashValue(entry, (ClientData) attrs); - } - attrs = (ItemAttr *)Tcl_GetHashValue(entry); - return attrs; -} - -/* - *---------------------------------------------------------------------- - * - * DestroyListbox -- - * - * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release - * to clean up the internal structure of a listbox at a safe time - * (when no-one is using it anymore). - * - * Results: - * None. - * - * Side effects: - * Everything associated with the listbox is freed up. - * - *---------------------------------------------------------------------- - */ - -static void -DestroyListbox(memPtr) - char *memPtr; /* Info about listbox widget. */ -{ - register Listbox *listPtr = (Listbox *) memPtr; - Tcl_HashEntry *entry; - Tcl_HashSearch search; - - listPtr->flags |= LISTBOX_DELETED; - - Tcl_DeleteCommandFromToken(listPtr->interp, listPtr->widgetCmd); - if (listPtr->setGrid) { - Tk_UnsetGrid(listPtr->tkwin); - } - if (listPtr->flags & REDRAW_PENDING) { - Tcl_CancelIdleCall(DisplayListbox, (ClientData) listPtr); - } - - /* If we have an internal list object, free it */ - if (listPtr->listObj != NULL) { - Tcl_DecrRefCount(listPtr->listObj); - listPtr->listObj = NULL; - } - - if (listPtr->listVarName != NULL) { - Tcl_UntraceVar(listPtr->interp, listPtr->listVarName, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - ListboxListVarProc, (ClientData) listPtr); - } - - /* Free the selection hash table */ - Tcl_DeleteHashTable(listPtr->selection); - ckfree((char *)listPtr->selection); - - /* Free the item attribute hash table */ - for (entry = Tcl_FirstHashEntry(listPtr->itemAttrTable, &search); - entry != NULL; entry = Tcl_NextHashEntry(&search)) { - ckfree((char *)Tcl_GetHashValue(entry)); - } - Tcl_DeleteHashTable(listPtr->itemAttrTable); - ckfree((char *)listPtr->itemAttrTable); - - /* - * Free up all the stuff that requires special handling, then - * let Tk_FreeOptions handle all the standard option-related - * stuff. - */ - - if (listPtr->textGC != None) { - Tk_FreeGC(listPtr->display, listPtr->textGC); - } - if (listPtr->selTextGC != None) { - Tk_FreeGC(listPtr->display, listPtr->selTextGC); - } - Tk_FreeConfigOptions((char *)listPtr, listPtr->optionTable, - listPtr->tkwin); - listPtr->tkwin = NULL; - ckfree((char *) listPtr); -} - -/* - *---------------------------------------------------------------------- - * - * DestroyListboxOptionTables -- - * - * This procedure is registered as an exit callback when the listbox - * command is first called. It cleans up the OptionTables structure - * allocated by that command. - * - * Results: - * None. - * - * Side effects: - * Frees memory. - * - *---------------------------------------------------------------------- - */ - -static void -DestroyListboxOptionTables(clientData, interp) - ClientData clientData; /* Pointer to the OptionTables struct */ - Tcl_Interp *interp; /* Pointer to the calling interp */ -{ - ckfree((char *)clientData); - return; -} - -/* - *---------------------------------------------------------------------- - * - * ConfigureListbox -- - * - * This procedure is called to process an objv/objc list, plus - * the Tk option database, in order to configure (or reconfigure) - * a listbox widget. - * - * Results: - * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then the interp's result contains an error message. - * - * Side effects: - * Configuration information, such as colors, border width, - * etc. get set for listPtr; old resources get freed, - * if there were any. - * - *---------------------------------------------------------------------- - */ - -static int -ConfigureListbox(interp, listPtr, objc, objv, flags) - Tcl_Interp *interp; /* Used for error reporting. */ - register Listbox *listPtr; /* Information about widget; may or may - * not already have values for some fields. */ - int objc; /* Number of valid entries in argv. */ - Tcl_Obj *CONST objv[]; /* Arguments. */ - int flags; /* Flags to pass to Tk_ConfigureWidget. */ -{ - Tk_SavedOptions savedOptions; - Tcl_Obj *oldListObj = NULL; - int oldExport; - - oldExport = listPtr->exportSelection; - if (listPtr->listVarName != NULL) { - Tcl_UntraceVar(interp, listPtr->listVarName, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - ListboxListVarProc, (ClientData) listPtr); - } - - if (Tk_SetOptions(interp, (char *)listPtr, - listPtr->optionTable, objc, objv, listPtr->tkwin, - &savedOptions, (int *)NULL) != TCL_OK) { - Tk_RestoreSavedOptions(&savedOptions); - return TCL_ERROR; - } - - /* - * A few options need special processing, such as setting the - * background from a 3-D border. - */ - - Tk_SetBackgroundFromBorder(listPtr->tkwin, listPtr->normalBorder); - - if (listPtr->highlightWidth < 0) { - listPtr->highlightWidth = 0; - } - listPtr->inset = listPtr->highlightWidth + listPtr->borderWidth; - - /* - * Claim the selection if we've suddenly started exporting it and - * there is a selection to export. - */ - - if (listPtr->exportSelection && !oldExport - && (listPtr->numSelected != 0)) { - Tk_OwnSelection(listPtr->tkwin, XA_PRIMARY, ListboxLostSelection, - (ClientData) listPtr); - } - - - /* Verify the current status of the list var. - * PREVIOUS STATE | NEW STATE | ACTION - * ------------------+---------------+---------------------------------- - * no listvar | listvar | If listvar does not exist, create - * it and copy the internal list obj's - * content to the new var. If it does - * exist, toss the internal list obj. - * - * listvar | no listvar | Copy old listvar content to the - * internal list obj - * - * listvar | listvar | no special action - * - * no listvar | no listvar | no special action - */ - oldListObj = listPtr->listObj; - if (listPtr->listVarName != NULL) { - Tcl_Obj *listVarObj = Tcl_GetVar2Ex(interp, listPtr->listVarName, - (char *)NULL, TCL_GLOBAL_ONLY); - int dummy; - if (listVarObj == NULL) { - if (listPtr->listObj != NULL) { - listVarObj = listPtr->listObj; - } else { - listVarObj = Tcl_NewObj(); - } - if (Tcl_SetVar2Ex(interp, listPtr->listVarName, (char *)NULL, - listVarObj, TCL_GLOBAL_ONLY) == NULL) { - Tcl_DecrRefCount(listVarObj); - Tk_RestoreSavedOptions(&savedOptions); - return TCL_ERROR; - } - } - /* Make sure the object is a good list object */ - if (Tcl_ListObjLength(listPtr->interp, listVarObj, &dummy) != TCL_OK) { - Tk_RestoreSavedOptions(&savedOptions); - Tcl_AppendResult(listPtr->interp, ": invalid listvar value", - (char *)NULL); - return TCL_ERROR; - } - - listPtr->listObj = listVarObj; - Tcl_TraceVar(listPtr->interp, listPtr->listVarName, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - ListboxListVarProc, (ClientData) listPtr); - } else { - if (listPtr->listObj == NULL) { - listPtr->listObj = Tcl_NewObj(); - } - } - Tcl_IncrRefCount(listPtr->listObj); - if (oldListObj != NULL) { - Tcl_DecrRefCount(oldListObj); - } - - /* Make sure that the list length is correct */ - Tcl_ListObjLength(listPtr->interp, listPtr->listObj, &listPtr->nElements); - - Tk_FreeSavedOptions(&savedOptions); - ListboxWorldChanged((ClientData) listPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ConfigureListboxItem -- - * - * This procedure is called to process an objv/objc list, plus - * the Tk option database, in order to configure (or reconfigure) - * a listbox item. - * - * Results: - * The return value is a standard Tcl result. If TCL_ERROR is - * returned, then the interp's result contains an error message. - * - * Side effects: - * Configuration information, such as colors, border width, - * etc. get set for a listbox item; old resources get freed, - * if there were any. - * - *---------------------------------------------------------------------- - */ - -static int -ConfigureListboxItem(interp, listPtr, attrs, objc, objv) - Tcl_Interp *interp; /* Used for error reporting. */ - register Listbox *listPtr; /* Information about widget; may or may - * not already have values for some fields. */ - ItemAttr *attrs; /* Information about the item to configure */ - int objc; /* Number of valid entries in argv. */ - Tcl_Obj *CONST objv[]; /* Arguments. */ -{ - Tk_SavedOptions savedOptions; - - if (Tk_SetOptions(interp, (char *)attrs, - listPtr->itemAttrOptionTable, objc, objv, listPtr->tkwin, - &savedOptions, (int *)NULL) != TCL_OK) { - Tk_RestoreSavedOptions(&savedOptions); - return TCL_ERROR; - } - Tk_FreeSavedOptions(&savedOptions); - ListboxWorldChanged((ClientData) listPtr); - return TCL_OK; -} - -/* - *--------------------------------------------------------------------------- - * - * ListboxWorldChanged -- - * - * This procedure is called when the world has changed in some - * way and the widget needs to recompute all its graphics contexts - * and determine its new geometry. - * - * Results: - * None. - * - * Side effects: - * Listbox will be relayed out and redisplayed. - * - *--------------------------------------------------------------------------- - */ - -static void -ListboxWorldChanged(instanceData) - ClientData instanceData; /* Information about widget. */ -{ - XGCValues gcValues; - GC gc; - unsigned long mask; - Listbox *listPtr; - - listPtr = (Listbox *) instanceData; - - gcValues.foreground = listPtr->fgColorPtr->pixel; - gcValues.font = Tk_FontId(listPtr->tkfont); - gcValues.graphics_exposures = False; - mask = GCForeground | GCFont | GCGraphicsExposures; - gc = Tk_GetGC(listPtr->tkwin, mask, &gcValues); - if (listPtr->textGC != None) { - Tk_FreeGC(listPtr->display, listPtr->textGC); - } - listPtr->textGC = gc; - - gcValues.foreground = listPtr->selFgColorPtr->pixel; - gcValues.font = Tk_FontId(listPtr->tkfont); - mask = GCForeground | GCFont; - gc = Tk_GetGC(listPtr->tkwin, mask, &gcValues); - if (listPtr->selTextGC != None) { - Tk_FreeGC(listPtr->display, listPtr->selTextGC); - } - listPtr->selTextGC = gc; - - /* - * Register the desired geometry for the window and arrange for - * the window to be redisplayed. - */ - - ListboxComputeGeometry(listPtr, 1, 1, 1); - listPtr->flags |= UPDATE_V_SCROLLBAR|UPDATE_H_SCROLLBAR; - EventuallyRedrawRange(listPtr, 0, listPtr->nElements-1); -} - -/* - *-------------------------------------------------------------- - * - * DisplayListbox -- - * - * This procedure redraws the contents of a listbox window. - * - * Results: - * None. - * - * Side effects: - * Information appears on the screen. - * - *-------------------------------------------------------------- - */ - -static void -DisplayListbox(clientData) - ClientData clientData; /* Information about window. */ -{ - register Listbox *listPtr = (Listbox *) clientData; - register Tk_Window tkwin = listPtr->tkwin; - GC gc; - int i, limit, x, y, width, prevSelected; - Tk_FontMetrics fm; - Tcl_Obj *curElement; - Tcl_HashEntry *entry; - char *stringRep; - int stringLen; - ItemAttr *attrs; - Tk_3DBorder selectedBg; - XGCValues gcValues; - unsigned long mask; - int left, right; /* Non-zero values here indicate - * that the left or right edge of - * the listbox is off-screen. */ - Pixmap pixmap; - - listPtr->flags &= ~REDRAW_PENDING; - - if (listPtr->flags & MAXWIDTH_IS_STALE) { - ListboxComputeGeometry(listPtr, 0, 1, 0); - listPtr->flags &= ~MAXWIDTH_IS_STALE; - listPtr->flags |= UPDATE_H_SCROLLBAR; - } - - if (listPtr->flags & UPDATE_V_SCROLLBAR) { - ListboxUpdateVScrollbar(listPtr); - } - if (listPtr->flags & UPDATE_H_SCROLLBAR) { - ListboxUpdateHScrollbar(listPtr); - } - listPtr->flags &= ~(REDRAW_PENDING|UPDATE_V_SCROLLBAR|UPDATE_H_SCROLLBAR); - if ((listPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { - return; - } - - /* - * Redrawing is done in a temporary pixmap that is allocated - * here and freed at the end of the procedure. All drawing is - * done to the pixmap, and the pixmap is copied to the screen - * at the end of the procedure. This provides the smoothest - * possible visual effects (no flashing on the screen). - */ - - pixmap = Tk_GetPixmap(listPtr->display, Tk_WindowId(tkwin), - Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin)); - Tk_Fill3DRectangle(tkwin, pixmap, listPtr->normalBorder, 0, 0, - Tk_Width(tkwin), Tk_Height(tkwin), 0, TK_RELIEF_FLAT); - - /* Display each item in the listbox */ - limit = listPtr->topIndex + listPtr->fullLines + listPtr->partialLine - 1; - if (limit >= listPtr->nElements) { - limit = listPtr->nElements-1; - } - left = right = 0; - if (listPtr->xOffset > 0) { - left = listPtr->selBorderWidth+1; - } - if ((listPtr->maxWidth - listPtr->xOffset) > (Tk_Width(listPtr->tkwin) - - 2*(listPtr->inset + listPtr->selBorderWidth))) { - right = listPtr->selBorderWidth+1; - } - prevSelected = 0; - - for (i = listPtr->topIndex; i <= limit; i++) { - x = listPtr->inset; - y = ((i - listPtr->topIndex) * listPtr->lineHeight) - + listPtr->inset; - gc = listPtr->textGC; - /* - * Lookup this item in the item attributes table, to see if it has - * special foreground/background colors - */ - entry = Tcl_FindHashEntry(listPtr->itemAttrTable, (char *)i); - - /* If the item is selected, it is drawn differently */ - if (Tcl_FindHashEntry(listPtr->selection, (char *)i) != NULL) { - gc = listPtr->selTextGC; - width = Tk_Width(tkwin) - 2*listPtr->inset; - selectedBg = listPtr->selBorder; - - /* If there is attribute information for this item, - * adjust the drawing accordingly */ - if (entry != NULL) { - attrs = (ItemAttr *)Tcl_GetHashValue(entry); - /* The default GC has the settings from the widget at large */ - gcValues.foreground = listPtr->selFgColorPtr->pixel; - gcValues.font = Tk_FontId(listPtr->tkfont); - gcValues.graphics_exposures = False; - mask = GCForeground | GCFont | GCGraphicsExposures; - - if (attrs->selBorder != NULL) { - selectedBg = attrs->selBorder; - } - - if (attrs->selFgColor != NULL) { - gcValues.foreground = attrs->selFgColor->pixel; - gc = Tk_GetGC(listPtr->tkwin, mask, &gcValues); - } - } - - Tk_Fill3DRectangle(tkwin, pixmap, selectedBg, x, y, - width, listPtr->lineHeight, 0, TK_RELIEF_FLAT); - - /* - * Draw beveled edges around the selection, if there are visible - * edges next to this element. Special considerations: - * 1. The left and right bevels may not be visible if horizontal - * scrolling is enabled (the "left" and "right" variables - * are zero to indicate that the corresponding bevel is - * visible). - * 2. Top and bottom bevels are only drawn if this is the - * first or last seleted item. - * 3. If the left or right bevel isn't visible, then the "left" - * and "right" variables, computed above, have non-zero values - * that extend the top and bottom bevels so that the mitered - * corners are off-screen. - */ - - /* Draw left bevel */ - if (left == 0) { - Tk_3DVerticalBevel(tkwin, pixmap, selectedBg, - x, y, listPtr->selBorderWidth, listPtr->lineHeight, - 1, TK_RELIEF_RAISED); - } - /* Draw right bevel */ - if (right == 0) { - Tk_3DVerticalBevel(tkwin, pixmap, selectedBg, - x + width - listPtr->selBorderWidth, y, - listPtr->selBorderWidth, listPtr->lineHeight, - 0, TK_RELIEF_RAISED); - } - /* Draw top bevel */ - if (!prevSelected) { - Tk_3DHorizontalBevel(tkwin, pixmap, selectedBg, - x-left, y, width+left+right, listPtr->selBorderWidth, - 1, 1, 1, TK_RELIEF_RAISED); - } - /* Draw bottom bevel */ - if (i + 1 == listPtr->nElements || - Tcl_FindHashEntry(listPtr->selection, - (char *)(i + 1)) == NULL ) { - Tk_3DHorizontalBevel(tkwin, pixmap, selectedBg, x-left, - y + listPtr->lineHeight - listPtr->selBorderWidth, - width+left+right, listPtr->selBorderWidth, 0, 0, 0, - TK_RELIEF_RAISED); - } - prevSelected = 1; - } else { - /* If there is an item attributes record for this item, - * draw the background box and set the foreground color - * accordingly */ - if (entry != NULL) { - attrs = (ItemAttr *)Tcl_GetHashValue(entry); - gcValues.foreground = listPtr->fgColorPtr->pixel; - gcValues.font = Tk_FontId(listPtr->tkfont); - gcValues.graphics_exposures = False; - mask = GCForeground | GCFont | GCGraphicsExposures; - if (attrs->border != NULL) { - width = Tk_Width(tkwin) - 2*listPtr->inset; - Tk_Fill3DRectangle(tkwin, pixmap, attrs->border, x, y, - width, listPtr->lineHeight, 0, TK_RELIEF_FLAT); - } - if (attrs->fgColor != NULL) { - gcValues.foreground = attrs->fgColor->pixel; - gc = Tk_GetGC(listPtr->tkwin, mask, &gcValues); - } - } - prevSelected = 0; - } - - /* Draw the actual text of this item */ - Tk_GetFontMetrics(listPtr->tkfont, &fm); - y += fm.ascent + listPtr->selBorderWidth; - x = listPtr->inset + listPtr->selBorderWidth - listPtr->xOffset; - Tcl_ListObjIndex(listPtr->interp, listPtr->listObj, i, &curElement); - stringRep = Tcl_GetStringFromObj(curElement, &stringLen); - Tk_DrawChars(listPtr->display, pixmap, gc, listPtr->tkfont, - stringRep, stringLen, x, y); - - /* If this is the active element, underline it. */ - if ((i == listPtr->active) && (listPtr->flags & GOT_FOCUS)) { - Tk_UnderlineChars(listPtr->display, pixmap, gc, listPtr->tkfont, - stringRep, x, y, 0, stringLen); - } - } - - /* - * Redraw the border for the listbox to make sure that it's on top - * of any of the text of the listbox entries. - */ - - Tk_Draw3DRectangle(tkwin, pixmap, listPtr->normalBorder, - listPtr->highlightWidth, listPtr->highlightWidth, - Tk_Width(tkwin) - 2*listPtr->highlightWidth, - Tk_Height(tkwin) - 2*listPtr->highlightWidth, - listPtr->borderWidth, listPtr->relief); - if (listPtr->highlightWidth > 0) { - GC fgGC, bgGC; - - bgGC = Tk_GCForColor(listPtr->highlightBgColorPtr, pixmap); - if (listPtr->flags & GOT_FOCUS) { - fgGC = Tk_GCForColor(listPtr->highlightColorPtr, pixmap); - TkpDrawHighlightBorder(tkwin, fgGC, bgGC, - listPtr->highlightWidth, pixmap); - } else { - TkpDrawHighlightBorder(tkwin, bgGC, bgGC, - listPtr->highlightWidth, pixmap); - } - } - XCopyArea(listPtr->display, pixmap, Tk_WindowId(tkwin), - listPtr->textGC, 0, 0, (unsigned) Tk_Width(tkwin), - (unsigned) Tk_Height(tkwin), 0, 0); - Tk_FreePixmap(listPtr->display, pixmap); -} - -/* - *---------------------------------------------------------------------- - * - * ListboxComputeGeometry -- - * - * This procedure is invoked to recompute geometry information - * such as the sizes of the elements and the overall dimensions - * desired for the listbox. - * - * Results: - * None. - * - * Side effects: - * Geometry information is updated and a new requested size is - * registered for the widget. Internal border and gridding - * information is also set. - * - *---------------------------------------------------------------------- - */ - -static void -ListboxComputeGeometry(listPtr, fontChanged, maxIsStale, updateGrid) - Listbox *listPtr; /* Listbox whose geometry is to be - * recomputed. */ - int fontChanged; /* Non-zero means the font may have changed - * so per-element width information also - * has to be computed. */ - int maxIsStale; /* Non-zero means the "maxWidth" field may - * no longer be up-to-date and must - * be recomputed. If fontChanged is 1 then - * this must be 1. */ - int updateGrid; /* Non-zero means call Tk_SetGrid or - * Tk_UnsetGrid to update gridding for - * the window. */ -{ - int width, height, pixelWidth, pixelHeight; - Tk_FontMetrics fm; - Tcl_Obj *element; - int textLength; - char *text; - int i, result; - - if (fontChanged || maxIsStale) { - listPtr->xScrollUnit = Tk_TextWidth(listPtr->tkfont, "0", 1); - if (listPtr->xScrollUnit == 0) { - listPtr->xScrollUnit = 1; - } - listPtr->maxWidth = 0; - for (i = 0; i < listPtr->nElements; i++) { - /* Compute the pixel width of the current element */ - result = Tcl_ListObjIndex(listPtr->interp, listPtr->listObj, i, - &element); - if (result != TCL_OK) { - continue; - } - text = Tcl_GetStringFromObj(element, &textLength); - Tk_GetFontMetrics(listPtr->tkfont, &fm); - pixelWidth = Tk_TextWidth(listPtr->tkfont, text, textLength); - if (pixelWidth > listPtr->maxWidth) { - listPtr->maxWidth = pixelWidth; - } - } - } - - Tk_GetFontMetrics(listPtr->tkfont, &fm); - listPtr->lineHeight = fm.linespace + 1 + 2*listPtr->selBorderWidth; - width = listPtr->width; - if (width <= 0) { - width = (listPtr->maxWidth + listPtr->xScrollUnit - 1) - /listPtr->xScrollUnit; - if (width < 1) { - width = 1; - } - } - pixelWidth = width*listPtr->xScrollUnit + 2*listPtr->inset - + 2*listPtr->selBorderWidth; - height = listPtr->height; - if (listPtr->height <= 0) { - height = listPtr->nElements; - if (height < 1) { - height = 1; - } - } - pixelHeight = height*listPtr->lineHeight + 2*listPtr->inset; - Tk_GeometryRequest(listPtr->tkwin, pixelWidth, pixelHeight); - Tk_SetInternalBorder(listPtr->tkwin, listPtr->inset); - if (updateGrid) { - if (listPtr->setGrid) { - Tk_SetGrid(listPtr->tkwin, width, height, listPtr->xScrollUnit, - listPtr->lineHeight); - } else { - Tk_UnsetGrid(listPtr->tkwin); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * ListboxInsertSubCmd -- - * - * This procedure is invoked to handle the listbox "insert" - * subcommand. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * New elements are added to the listbox pointed to by listPtr; - * a refresh callback is registered for the listbox. - * - *---------------------------------------------------------------------- - */ - -static int -ListboxInsertSubCmd(listPtr, index, objc, objv) - register Listbox *listPtr; /* Listbox that is to get the new - * elements. */ - int index; /* Add the new elements before this - * element. */ - int objc; /* Number of new elements to add. */ - Tcl_Obj *CONST objv[]; /* New elements (one per entry). */ -{ - int i, oldMaxWidth; - Tcl_Obj *newListObj; - int pixelWidth; - int result; - char *stringRep; - int length; - - oldMaxWidth = listPtr->maxWidth; - for (i = 0; i < objc; i++) { - /* - * Check if any of the new elements are wider than the current widest; - * if so, update our notion of "widest." - */ - stringRep = Tcl_GetStringFromObj(objv[i], &length); - pixelWidth = Tk_TextWidth(listPtr->tkfont, stringRep, length); - if (pixelWidth > listPtr->maxWidth) { - listPtr->maxWidth = pixelWidth; - } - } - - /* Adjust selection and attribute information for every index after - * the first index */ - MigrateHashEntries(listPtr->selection, index, listPtr->nElements-1, objc); - MigrateHashEntries(listPtr->itemAttrTable, index, listPtr->nElements-1, - objc); - - /* If the object is shared, duplicate it before writing to it */ - if (Tcl_IsShared(listPtr->listObj)) { - newListObj = Tcl_DuplicateObj(listPtr->listObj); - } else { - newListObj = listPtr->listObj; - } - result = - Tcl_ListObjReplace(listPtr->interp, newListObj, index, 0, objc, objv); - if (result != TCL_OK) { - return result; - } - - Tcl_IncrRefCount(newListObj); - /* Clean up the old reference */ - Tcl_DecrRefCount(listPtr->listObj); - - /* Set the internal pointer to the new obj */ - listPtr->listObj = newListObj; - - /* If there is a listvar, make sure it points at the new object */ - if (listPtr->listVarName != NULL) { - if (Tcl_SetVar2Ex(listPtr->interp, listPtr->listVarName, - (char *)NULL, newListObj, TCL_GLOBAL_ONLY) == NULL) { - Tcl_DecrRefCount(newListObj); - return TCL_ERROR; - } - } - - /* Get the new list length */ - Tcl_ListObjLength(listPtr->interp, listPtr->listObj, &listPtr->nElements); - - /* - * Update the "special" indices (anchor, topIndex, active) to account - * for the renumbering that just occurred. Then arrange for the new - * information to be displayed. - */ - - if (index <= listPtr->selectAnchor) { - listPtr->selectAnchor += objc; - } - if (index < listPtr->topIndex) { - listPtr->topIndex += objc; - } - if (index <= listPtr->active) { - listPtr->active += objc; - if ((listPtr->active >= listPtr->nElements) && - (listPtr->nElements > 0)) { - listPtr->active = listPtr->nElements-1; - } - } - listPtr->flags |= UPDATE_V_SCROLLBAR; - if (listPtr->maxWidth != oldMaxWidth) { - listPtr->flags |= UPDATE_H_SCROLLBAR; - } - ListboxComputeGeometry(listPtr, 0, 0, 0); - EventuallyRedrawRange(listPtr, index, listPtr->nElements-1); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ListboxDeleteSubCmd -- - * - * Process a listbox "delete" subcommand by removing one or more - * elements from a listbox widget. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * The listbox will be modified and (eventually) redisplayed. - * - *---------------------------------------------------------------------- - */ - -static int -ListboxDeleteSubCmd(listPtr, first, last) - register Listbox *listPtr; /* Listbox widget to modify. */ - int first; /* Index of first element to delete. */ - int last; /* Index of last element to delete. */ -{ - int count, i, widthChanged; - Tcl_Obj *newListObj; - Tcl_Obj *element; - int length; - char *stringRep; - int result; - int pixelWidth; - Tcl_HashEntry *entry; - - /* - * Adjust the range to fit within the existing elements of the - * listbox, and make sure there's something to delete. - */ - - if (first < 0) { - first = 0; - } - if (last >= listPtr->nElements) { - last = listPtr->nElements-1; - } - count = last + 1 - first; - if (count <= 0) { - return TCL_OK; - } - - /* - * Foreach deleted index we must: - * a) remove selection information - * b) check the width of the element; if it is equal to the max, set - * widthChanged to 1, because it may be the only element with that - * width - */ - widthChanged = 0; - for (i = first; i <= last; i++) { - /* Remove selection information */ - entry = Tcl_FindHashEntry(listPtr->selection, (char *)i); - if (entry != NULL) { - listPtr->numSelected--; - Tcl_DeleteHashEntry(entry); - } - - entry = Tcl_FindHashEntry(listPtr->itemAttrTable, (char *)i); - if (entry != NULL) { - Tcl_DeleteHashEntry(entry); - } - - /* Check width of the element. We only have to check if widthChanged - * has not already been set to 1, because we only need one maxWidth - * element to disappear for us to have to recompute the width - */ - if (widthChanged == 0) { - Tcl_ListObjIndex(listPtr->interp, listPtr->listObj, i, &element); - stringRep = Tcl_GetStringFromObj(element, &length); - pixelWidth = Tk_TextWidth(listPtr->tkfont, stringRep, length); - if (pixelWidth == listPtr->maxWidth) { - widthChanged = 1; - } - } - } - - /* Adjust selection and attribute info for indices after lastIndex */ - MigrateHashEntries(listPtr->selection, last+1, - listPtr->nElements-1, count*-1); - MigrateHashEntries(listPtr->itemAttrTable, last+1, - listPtr->nElements-1, count*-1); - - /* Delete the requested elements */ - if (Tcl_IsShared(listPtr->listObj)) { - newListObj = Tcl_DuplicateObj(listPtr->listObj); - } else { - newListObj = listPtr->listObj; - } - result = Tcl_ListObjReplace(listPtr->interp, - newListObj, first, count, 0, NULL); - if (result != TCL_OK) { - return result; - } - - Tcl_IncrRefCount(newListObj); - /* Clean up the old reference */ - Tcl_DecrRefCount(listPtr->listObj); - - /* Set the internal pointer to the new obj */ - listPtr->listObj = newListObj; - - /* Get the new list length */ - Tcl_ListObjLength(listPtr->interp, listPtr->listObj, &listPtr->nElements); - - /* If there is a listvar, make sure it points at the new object */ - if (listPtr->listVarName != NULL) { - if (Tcl_SetVar2Ex(listPtr->interp, listPtr->listVarName, - (char *)NULL, newListObj, TCL_GLOBAL_ONLY) == NULL) { - Tcl_DecrRefCount(newListObj); - return TCL_ERROR; - } - } - - /* - * Update the selection and viewing information to reflect the change - * in the element numbering, and redisplay to slide information up over - * the elements that were deleted. - */ - - if (first <= listPtr->selectAnchor) { - listPtr->selectAnchor -= count; - if (listPtr->selectAnchor < first) { - listPtr->selectAnchor = first; - } - } - if (first <= listPtr->topIndex) { - listPtr->topIndex -= count; - if (listPtr->topIndex < first) { - listPtr->topIndex = first; - } - } - if (listPtr->topIndex > (listPtr->nElements - listPtr->fullLines)) { - listPtr->topIndex = listPtr->nElements - listPtr->fullLines; - if (listPtr->topIndex < 0) { - listPtr->topIndex = 0; - } - } - if (listPtr->active > last) { - listPtr->active -= count; - } else if (listPtr->active >= first) { - listPtr->active = first; - if ((listPtr->active >= listPtr->nElements) && - (listPtr->nElements > 0)) { - listPtr->active = listPtr->nElements-1; - } - } - listPtr->flags |= UPDATE_V_SCROLLBAR; - ListboxComputeGeometry(listPtr, 0, widthChanged, 0); - if (widthChanged) { - listPtr->flags |= UPDATE_H_SCROLLBAR; - } - EventuallyRedrawRange(listPtr, first, listPtr->nElements-1); - return TCL_OK; -} - -/* - *-------------------------------------------------------------- - * - * ListboxEventProc -- - * - * This procedure is invoked by the Tk dispatcher for various - * events on listboxes. - * - * Results: - * None. - * - * Side effects: - * When the window gets deleted, internal structures get - * cleaned up. When it gets exposed, it is redisplayed. - * - *-------------------------------------------------------------- - */ - -static void -ListboxEventProc(clientData, eventPtr) - ClientData clientData; /* Information about window. */ - XEvent *eventPtr; /* Information about event. */ -{ - Listbox *listPtr = (Listbox *) clientData; - - if (eventPtr->type == Expose) { - EventuallyRedrawRange(listPtr, - NearestListboxElement(listPtr, eventPtr->xexpose.y), - NearestListboxElement(listPtr, eventPtr->xexpose.y - + eventPtr->xexpose.height)); - } else if (eventPtr->type == DestroyNotify) { - DestroyListbox((char *) clientData); - } else if (eventPtr->type == ConfigureNotify) { - int vertSpace; - - vertSpace = Tk_Height(listPtr->tkwin) - 2*listPtr->inset; - listPtr->fullLines = vertSpace / listPtr->lineHeight; - if ((listPtr->fullLines*listPtr->lineHeight) < vertSpace) { - listPtr->partialLine = 1; - } else { - listPtr->partialLine = 0; - } - listPtr->flags |= UPDATE_V_SCROLLBAR|UPDATE_H_SCROLLBAR; - ChangeListboxView(listPtr, listPtr->topIndex); - ChangeListboxOffset(listPtr, listPtr->xOffset); - - /* - * Redraw the whole listbox. It's hard to tell what needs - * to be redrawn (e.g. if the listbox has shrunk then we - * may only need to redraw the borders), so just redraw - * everything for safety. - */ - - EventuallyRedrawRange(listPtr, 0, listPtr->nElements-1); - } else if (eventPtr->type == FocusIn) { - if (eventPtr->xfocus.detail != NotifyInferior) { - listPtr->flags |= GOT_FOCUS; - EventuallyRedrawRange(listPtr, 0, listPtr->nElements-1); - } - } else if (eventPtr->type == FocusOut) { - if (eventPtr->xfocus.detail != NotifyInferior) { - listPtr->flags &= ~GOT_FOCUS; - EventuallyRedrawRange(listPtr, 0, listPtr->nElements-1); - } - } -} - -/* - *---------------------------------------------------------------------- - * - * ListboxCmdDeletedProc -- - * - * This procedure is invoked when a widget command is deleted. If - * the widget isn't already in the process of being destroyed, - * this command destroys it. - * - * Results: - * None. - * - * Side effects: - * The widget is destroyed. - * - *---------------------------------------------------------------------- - */ - -static void -ListboxCmdDeletedProc(clientData) - ClientData clientData; /* Pointer to widget record for widget. */ -{ - Listbox *listPtr = (Listbox *) clientData; - - /* - * This procedure could be invoked either because the window was - * destroyed and the command was then deleted (in which case tkwin - * is NULL) or because the command was deleted, and then this procedure - * destroys the widget. - */ - - if (!(listPtr->flags & LISTBOX_DELETED)) { - Tk_DestroyWindow(listPtr->tkwin); - } -} - -/* - *-------------------------------------------------------------- - * - * GetListboxIndex -- - * - * Parse an index into a listbox and return either its value - * or an error. - * - * Results: - * A standard Tcl result. If all went well, then *indexPtr is - * filled in with the index (into listPtr) corresponding to - * string. Otherwise an error message is left in the interp's result. - * - * Side effects: - * None. - * - *-------------------------------------------------------------- - */ - -static int -GetListboxIndex(interp, listPtr, indexObj, endIsSize, indexPtr) - Tcl_Interp *interp; /* For error messages. */ - Listbox *listPtr; /* Listbox for which the index is being - * specified. */ - Tcl_Obj *indexObj; /* Specifies an element in the listbox. */ - int endIsSize; /* If 1, "end" refers to the number of - * entries in the listbox. If 0, "end" - * refers to 1 less than the number of - * entries. */ - int *indexPtr; /* Where to store converted index. */ -{ - int result; - int index; - char *stringRep; - - /* First see if the index is one of the named indices */ - result = Tcl_GetIndexFromObj(NULL, indexObj, indexNames, "", 0, &index); - if (result == TCL_OK) { - switch (index) { - case INDEX_ACTIVE: { - /* "active" index */ - *indexPtr = listPtr->active; - break; - } - - case INDEX_ANCHOR: { - /* "anchor" index */ - *indexPtr = listPtr->selectAnchor; - break; - } - - case INDEX_END: { - /* "end" index */ - if (endIsSize) { - *indexPtr = listPtr->nElements; - } else { - *indexPtr = listPtr->nElements - 1; - } - break; - } - } - return TCL_OK; - } - - /* The index didn't match any of the named indices; maybe it's an @x,y */ - stringRep = Tcl_GetString(indexObj); - if (stringRep[0] == '@') { - /* @x,y index */ - int y; - char *start, *end; - start = stringRep + 1; - strtol(start, &end, 0); - if ((start == end) || (*end != ',')) { - Tcl_AppendResult(interp, "bad listbox index \"", stringRep, - "\": must be active, anchor, end, @x,y, or a number", - (char *)NULL); - return TCL_ERROR; - } - start = end+1; - y = strtol(start, &end, 0); - if ((start == end) || (*end != '\0')) { - Tcl_AppendResult(interp, "bad listbox index \"", stringRep, - "\": must be active, anchor, end, @x,y, or a number", - (char *)NULL); - return TCL_ERROR; - } - *indexPtr = NearestListboxElement(listPtr, y); - return TCL_OK; - } - - /* Maybe the index is just an integer */ - if (Tcl_GetIntFromObj(interp, indexObj, indexPtr) == TCL_OK) { - return TCL_OK; - } - - /* Everything failed, nothing matched. Throw up an error message */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "bad listbox index \"", - Tcl_GetString(indexObj), "\": must be active, anchor, ", - "end, @x,y, or a number", (char *) NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * - * ChangeListboxView -- - * - * Change the view on a listbox widget so that a given element - * is displayed at the top. - * - * Results: - * None. - * - * Side effects: - * What's displayed on the screen is changed. If there is a - * scrollbar associated with this widget, then the scrollbar - * is instructed to change its display too. - * - *---------------------------------------------------------------------- - */ - -static void -ChangeListboxView(listPtr, index) - register Listbox *listPtr; /* Information about widget. */ - int index; /* Index of element in listPtr - * that should now appear at the - * top of the listbox. */ -{ - if (index >= (listPtr->nElements - listPtr->fullLines)) { - index = listPtr->nElements - listPtr->fullLines; - } - if (index < 0) { - index = 0; - } - if (listPtr->topIndex != index) { - listPtr->topIndex = index; - EventuallyRedrawRange(listPtr, 0, listPtr->nElements-1); - listPtr->flags |= UPDATE_V_SCROLLBAR; - } -} - -/* - *---------------------------------------------------------------------- - * - * ChangListboxOffset -- - * - * Change the horizontal offset for a listbox. - * - * Results: - * None. - * - * Side effects: - * The listbox may be redrawn to reflect its new horizontal - * offset. - * - *---------------------------------------------------------------------- - */ - -static void -ChangeListboxOffset(listPtr, offset) - register Listbox *listPtr; /* Information about widget. */ - int offset; /* Desired new "xOffset" for - * listbox. */ -{ - int maxOffset; - - /* - * Make sure that the new offset is within the allowable range, and - * round it off to an even multiple of xScrollUnit. - */ - - maxOffset = listPtr->maxWidth - (Tk_Width(listPtr->tkwin) - - 2*listPtr->inset - 2*listPtr->selBorderWidth) - + listPtr->xScrollUnit - 1; - if (offset > maxOffset) { - offset = maxOffset; - } - if (offset < 0) { - offset = 0; - } - offset -= offset % listPtr->xScrollUnit; - if (offset != listPtr->xOffset) { - listPtr->xOffset = offset; - listPtr->flags |= UPDATE_H_SCROLLBAR; - EventuallyRedrawRange(listPtr, 0, listPtr->nElements-1); - } -} - -/* - *---------------------------------------------------------------------- - * - * ListboxScanTo -- - * - * Given a point (presumably of the curent mouse location) - * drag the view in the window to implement the scan operation. - * - * Results: - * None. - * - * Side effects: - * The view in the window may change. - * - *---------------------------------------------------------------------- - */ - -static void -ListboxScanTo(listPtr, x, y) - register Listbox *listPtr; /* Information about widget. */ - int x; /* X-coordinate to use for scan - * operation. */ - int y; /* Y-coordinate to use for scan - * operation. */ -{ - int newTopIndex, newOffset, maxIndex, maxOffset; - - maxIndex = listPtr->nElements - listPtr->fullLines; - maxOffset = listPtr->maxWidth + (listPtr->xScrollUnit - 1) - - (Tk_Width(listPtr->tkwin) - 2*listPtr->inset - - 2*listPtr->selBorderWidth - listPtr->xScrollUnit); - - /* - * Compute new top line for screen by amplifying the difference - * between the current position and the place where the scan - * started (the "mark" position). If we run off the top or bottom - * of the list, then reset the mark point so that the current - * position continues to correspond to the edge of the window. - * This means that the picture will start dragging as soon as the - * mouse reverses direction (without this reset, might have to slide - * mouse a long ways back before the picture starts moving again). - */ - - newTopIndex = listPtr->scanMarkYIndex - - (10*(y - listPtr->scanMarkY))/listPtr->lineHeight; - if (newTopIndex > maxIndex) { - newTopIndex = listPtr->scanMarkYIndex = maxIndex; - listPtr->scanMarkY = y; - } else if (newTopIndex < 0) { - newTopIndex = listPtr->scanMarkYIndex = 0; - listPtr->scanMarkY = y; - } - ChangeListboxView(listPtr, newTopIndex); - - /* - * Compute new left edge for display in a similar fashion by amplifying - * the difference between the current position and the place where the - * scan started. - */ - - newOffset = listPtr->scanMarkXOffset - (10*(x - listPtr->scanMarkX)); - if (newOffset > maxOffset) { - newOffset = listPtr->scanMarkXOffset = maxOffset; - listPtr->scanMarkX = x; - } else if (newOffset < 0) { - newOffset = listPtr->scanMarkXOffset = 0; - listPtr->scanMarkX = x; - } - ChangeListboxOffset(listPtr, newOffset); -} - -/* - *---------------------------------------------------------------------- - * - * NearestListboxElement -- - * - * Given a y-coordinate inside a listbox, compute the index of - * the element under that y-coordinate (or closest to that - * y-coordinate). - * - * Results: - * The return value is an index of an element of listPtr. If - * listPtr has no elements, then 0 is always returned. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -NearestListboxElement(listPtr, y) - register Listbox *listPtr; /* Information about widget. */ - int y; /* Y-coordinate in listPtr's window. */ -{ - int index; - - index = (y - listPtr->inset)/listPtr->lineHeight; - if (index >= (listPtr->fullLines + listPtr->partialLine)) { - index = listPtr->fullLines + listPtr->partialLine - 1; - } - if (index < 0) { - index = 0; - } - index += listPtr->topIndex; - if (index >= listPtr->nElements) { - index = listPtr->nElements-1; - } - return index; -} - -/* - *---------------------------------------------------------------------- - * - * ListboxSelect -- - * - * Select or deselect one or more elements in a listbox.. - * - * Results: - * Standard Tcl result. - * - * Side effects: - * All of the elements in the range between first and last are - * marked as either selected or deselected, depending on the - * "select" argument. Any items whose state changes are redisplayed. - * The selection is claimed from X when the number of selected - * elements changes from zero to non-zero. - * - *---------------------------------------------------------------------- - */ - -static int -ListboxSelect(listPtr, first, last, select) - register Listbox *listPtr; /* Information about widget. */ - int first; /* Index of first element to - * select or deselect. */ - int last; /* Index of last element to - * select or deselect. */ - int select; /* 1 means select items, 0 means - * deselect them. */ -{ - int i, firstRedisplay, increment, oldCount; - Tcl_HashEntry *entry; - int new; - - if (last < first) { - i = first; - first = last; - last = i; - } - if ((last < 0) || (first >= listPtr->nElements)) { - return TCL_OK; - } - if (first < 0) { - first = 0; - } - if (last >= listPtr->nElements) { - last = listPtr->nElements - 1; - } - oldCount = listPtr->numSelected; - firstRedisplay = -1; - increment = select ? 1 : -1; - - /* - * For each index in the range, find it in our selection hash table. - * If it's not there but should be, add it. If it's there but shouldn't - * be, remove it. - */ - for (i = first; i <= last; i++) { - entry = Tcl_FindHashEntry(listPtr->selection, (char *)i); - if (entry != NULL) { - if (!select) { - Tcl_DeleteHashEntry(entry); - listPtr->numSelected--; - if (firstRedisplay < 0) { - firstRedisplay = i; - } - } - } else { - if (select) { - entry = Tcl_CreateHashEntry(listPtr->selection, - (char *)i, &new); - Tcl_SetHashValue(entry, (ClientData) NULL); - listPtr->numSelected++; - if (firstRedisplay < 0) { - firstRedisplay = i; - } - } - } - } - - if (firstRedisplay >= 0) { - EventuallyRedrawRange(listPtr, first, last); - } - if ((oldCount == 0) && (listPtr->numSelected > 0) - && (listPtr->exportSelection)) { - Tk_OwnSelection(listPtr->tkwin, XA_PRIMARY, ListboxLostSelection, - (ClientData) listPtr); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * ListboxFetchSelection -- - * - * This procedure is called back by Tk when the selection is - * requested by someone. It returns part or all of the selection - * in a buffer provided by the caller. - * - * Results: - * The return value is the number of non-NULL bytes stored - * at buffer. Buffer is filled (or partially filled) with a - * NULL-terminated string containing part or all of the selection, - * as given by offset and maxBytes. The selection is returned - * as a Tcl list with one list element for each element in the - * listbox. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -ListboxFetchSelection(clientData, offset, buffer, maxBytes) - ClientData clientData; /* Information about listbox widget. */ - int offset; /* Offset within selection of first - * byte to be returned. */ - char *buffer; /* Location in which to place - * selection. */ - int maxBytes; /* Maximum number of bytes to place - * at buffer, not including terminating - * NULL character. */ -{ - register Listbox *listPtr = (Listbox *) clientData; - Tcl_DString selection; - int length, count, needNewline; - Tcl_Obj *curElement; - char *stringRep; - int stringLen; - Tcl_HashEntry *entry; - int i; - - if (!listPtr->exportSelection) { - return -1; - } - - /* - * Use a dynamic string to accumulate the contents of the selection. - */ - - needNewline = 0; - Tcl_DStringInit(&selection); - for (i = 0; i < listPtr->nElements; i++) { - entry = Tcl_FindHashEntry(listPtr->selection, (char *)i); - if (entry != NULL) { - if (needNewline) { - Tcl_DStringAppend(&selection, "\n", 1); - } - Tcl_ListObjIndex(listPtr->interp, listPtr->listObj, i, - &curElement); - stringRep = Tcl_GetStringFromObj(curElement, &stringLen); - Tcl_DStringAppend(&selection, stringRep, stringLen); - needNewline = 1; - } - } - - length = Tcl_DStringLength(&selection); - if (length == 0) { - return -1; - } - - /* - * Copy the requested portion of the selection to the buffer. - */ - - count = length - offset; - if (count <= 0) { - count = 0; - } else { - if (count > maxBytes) { - count = maxBytes; - } - memcpy((VOID *) buffer, - (VOID *) (Tcl_DStringValue(&selection) + offset), - (size_t) count); - } - buffer[count] = '\0'; - Tcl_DStringFree(&selection); - return count; -} - -/* - *---------------------------------------------------------------------- - * - * ListboxLostSelection -- - * - * This procedure is called back by Tk when the selection is - * grabbed away from a listbox widget. - * - * Results: - * None. - * - * Side effects: - * The existing selection is unhighlighted, and the window is - * marked as not containing a selection. - * - *---------------------------------------------------------------------- - */ - -static void -ListboxLostSelection(clientData) - ClientData clientData; /* Information about listbox widget. */ -{ - register Listbox *listPtr = (Listbox *) clientData; - - if ((listPtr->exportSelection) && (listPtr->nElements > 0)) { - ListboxSelect(listPtr, 0, listPtr->nElements-1, 0); - } -} - -/* - *---------------------------------------------------------------------- - * - * EventuallyRedrawRange -- - * - * Ensure that a given range of elements is eventually redrawn on - * the display (if those elements in fact appear on the display). - * - * Results: - * None. - * - * Side effects: - * Information gets redisplayed. - * - *---------------------------------------------------------------------- - */ - -static void -EventuallyRedrawRange(listPtr, first, last) - register Listbox *listPtr; /* Information about widget. */ - int first; /* Index of first element in list - * that needs to be redrawn. */ - int last; /* Index of last element in list - * that needs to be redrawn. May - * be less than first; - * these just bracket a range. */ -{ - /* We don't have to register a redraw callback if one is already pending, - * or if the window doesn't exist, or if the window isn't mapped */ - if ((listPtr->flags & REDRAW_PENDING) - || (listPtr->tkwin == NULL) - || !Tk_IsMapped(listPtr->tkwin)) { - return; - } - listPtr->flags |= REDRAW_PENDING; - Tcl_DoWhenIdle(DisplayListbox, (ClientData) listPtr); -} - -/* - *---------------------------------------------------------------------- - * - * ListboxUpdateVScrollbar -- - * - * This procedure is invoked whenever information has changed in - * a listbox in a way that would invalidate a vertical scrollbar - * display. If there is an associated scrollbar, then this command - * updates it by invoking a Tcl command. - * - * Results: - * None. - * - * Side effects: - * A Tcl command is invoked, and an additional command may be - * invoked to process errors in the command. - * - *---------------------------------------------------------------------- - */ - -static void -ListboxUpdateVScrollbar(listPtr) - register Listbox *listPtr; /* Information about widget. */ -{ - char string[TCL_DOUBLE_SPACE * 2]; - double first, last; - int result; - Tcl_Interp *interp; - - if (listPtr->yScrollCmd == NULL) { - return; - } - if (listPtr->nElements == 0) { - first = 0.0; - last = 1.0; - } else { - first = listPtr->topIndex/((double) listPtr->nElements); - last = (listPtr->topIndex+listPtr->fullLines) - /((double) listPtr->nElements); - if (last > 1.0) { - last = 1.0; - } - } - sprintf(string, " %g %g", first, last); - - /* - * We must hold onto the interpreter from the listPtr because the data - * at listPtr might be freed as a result of the Tcl_VarEval. - */ - - interp = listPtr->interp; - Tcl_Preserve((ClientData) interp); - result = Tcl_VarEval(interp, listPtr->yScrollCmd, string, - (char *) NULL); - if (result != TCL_OK) { - Tcl_AddErrorInfo(interp, - "\n (vertical scrolling command executed by listbox)"); - Tcl_BackgroundError(interp); - } - Tcl_Release((ClientData) interp); -} - -/* - *---------------------------------------------------------------------- - * - * ListboxUpdateHScrollbar -- - * - * This procedure is invoked whenever information has changed in - * a listbox in a way that would invalidate a horizontal scrollbar - * display. If there is an associated horizontal scrollbar, then - * this command updates it by invoking a Tcl command. - * - * Results: - * None. - * - * Side effects: - * A Tcl command is invoked, and an additional command may be - * invoked to process errors in the command. - * - *---------------------------------------------------------------------- - */ - -static void -ListboxUpdateHScrollbar(listPtr) - register Listbox *listPtr; /* Information about widget. */ -{ - char string[TCL_DOUBLE_SPACE * 2]; - int result, windowWidth; - double first, last; - Tcl_Interp *interp; - - if (listPtr->xScrollCmd == NULL) { - return; - } - windowWidth = Tk_Width(listPtr->tkwin) - 2*(listPtr->inset - + listPtr->selBorderWidth); - if (listPtr->maxWidth == 0) { - first = 0; - last = 1.0; - } else { - first = listPtr->xOffset/((double) listPtr->maxWidth); - last = (listPtr->xOffset + windowWidth) - /((double) listPtr->maxWidth); - if (last > 1.0) { - last = 1.0; - } - } - sprintf(string, " %g %g", first, last); - - /* - * We must hold onto the interpreter because the data referred to at - * listPtr might be freed as a result of the call to Tcl_VarEval. - */ - - interp = listPtr->interp; - Tcl_Preserve((ClientData) interp); - result = Tcl_VarEval(interp, listPtr->xScrollCmd, string, - (char *) NULL); - if (result != TCL_OK) { - Tcl_AddErrorInfo(interp, - "\n (horizontal scrolling command executed by listbox)"); - Tcl_BackgroundError(interp); - } - Tcl_Release((ClientData) interp); -} - -/* - *---------------------------------------------------------------------- - * - * ListboxListVarProc -- - * - * Called whenever the trace on the listbox list var fires. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static char * -ListboxListVarProc(clientData, interp, name1, name2, flags) - ClientData clientData; /* Information about button. */ - Tcl_Interp *interp; /* Interpreter containing variable. */ - char *name1; /* Not used. */ - char *name2; /* Not used. */ - int flags; /* Information about what happened. */ -{ - Listbox *listPtr = (Listbox *)clientData; - Tcl_Obj *oldListObj, *varListObj; - int oldLength; - int i; - Tcl_HashEntry *entry; - - /* Bwah hahahaha -- puny mortal, you can't unset a -listvar'd variable! */ - if (flags & TCL_TRACE_UNSETS) { - if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { - Tcl_SetVar2Ex(interp, listPtr->listVarName, - (char *)NULL, listPtr->listObj, TCL_GLOBAL_ONLY); - Tcl_TraceVar(interp, listPtr->listVarName, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - ListboxListVarProc, clientData); - return (char *)NULL; - } - } else { - oldListObj = listPtr->listObj; - varListObj = Tcl_GetVar2Ex(listPtr->interp, listPtr->listVarName, - (char *)NULL, TCL_GLOBAL_ONLY); - /* - * Make sure the new value is a good list; if it's not, disallow - * the change -- the fact that it is a listvar means that it must - * always be a valid list -- and return an error message. - */ - if (Tcl_ListObjLength(listPtr->interp, varListObj, &i) != TCL_OK) { - Tcl_SetVar2Ex(interp, listPtr->listVarName, (char *)NULL, - oldListObj, TCL_GLOBAL_ONLY); - return("invalid listvar value"); - } - - listPtr->listObj = varListObj; - /* Incr the obj ref count so it doesn't vanish if the var is unset */ - Tcl_IncrRefCount(listPtr->listObj); - /* Clean up the ref to our old list obj */ - Tcl_DecrRefCount(oldListObj); - } - - /* - * If the list length has decreased, then we should clean up selection and - * attributes information for elements past the end of the new list - */ - oldLength = listPtr->nElements; - Tcl_ListObjLength(listPtr->interp, listPtr->listObj, &listPtr->nElements); - if (listPtr->nElements < oldLength) { - for (i = listPtr->nElements; i < oldLength; i++) { - /* Clean up selection */ - entry = Tcl_FindHashEntry(listPtr->selection, (char *)i); - if (entry != NULL) { - listPtr->numSelected--; - Tcl_DeleteHashEntry(entry); - } - - /* Clean up attributes */ - entry = Tcl_FindHashEntry(listPtr->itemAttrTable, (char *)i); - if (entry != NULL) { - Tcl_DeleteHashEntry(entry); - } - } - } - - if (oldLength != listPtr->nElements) { - listPtr->flags |= UPDATE_V_SCROLLBAR; - if (listPtr->topIndex > (listPtr->nElements - listPtr->fullLines)) { - listPtr->topIndex = listPtr->nElements - listPtr->fullLines; - if (listPtr->topIndex < 0) { - listPtr->topIndex = 0; - } - } - } - - /* - * The computed maxWidth may have changed as a result of this operation. - * However, we don't want to recompute it every time this trace fires - * (imagine the user doing 1000 lappends to the listvar). Therefore, set - * the MAXWIDTH_IS_STALE flag, which will cause the width to be recomputed - * next time the list is redrawn. - */ - listPtr->flags |= MAXWIDTH_IS_STALE; - - EventuallyRedrawRange(listPtr, 0, listPtr->nElements-1); - return (char*)NULL; -} - -/* - *---------------------------------------------------------------------- - * - * MigrateHashEntries -- - * - * Given a hash table with entries keyed by a single integer value, - * move all entries in a given range by a fixed amount, so that - * if in the original table there was an entry with key n and - * the offset was i, in the new table that entry would have key n + i. - * - * Results: - * None. - * - * Side effects: - * Rekeys some hash table entries. - * - *---------------------------------------------------------------------- - */ - -static void -MigrateHashEntries(table, first, last, offset) - Tcl_HashTable *table; - int first; - int last; - int offset; -{ - int i, new; - Tcl_HashEntry *entry; - ClientData clientData; - - if (offset == 0) { - return; - } - /* It's more efficient to do one if/else and nest the for loops inside, - * although we could avoid some code duplication if we nested the if/else - * inside the for loops */ - if (offset > 0) { - for (i = last; i >= first; i--) { - entry = Tcl_FindHashEntry(table, (char *)i); - if (entry != NULL) { - clientData = Tcl_GetHashValue(entry); - Tcl_DeleteHashEntry(entry); - entry = Tcl_CreateHashEntry(table, (char *)(i + offset), &new); - Tcl_SetHashValue(entry, clientData); - } - } - } else { - for (i = first; i <= last; i++) { - entry = Tcl_FindHashEntry(table, (char *)i); - if (entry != NULL) { - clientData = Tcl_GetHashValue(entry); - Tcl_DeleteHashEntry(entry); - entry = Tcl_CreateHashEntry(table, (char *)(i + offset), &new); - Tcl_SetHashValue(entry, clientData); - } - } - } - return; -} - - -/* $History: tkListbox.c $ - * - * ***************** Version 1 ***************** - * User: Dtashley Date: 1/02/01 Time: 3:01a - * Created in $/IjuScripter, IjuConsole/Source/Tk Base - * Initial check-in. - */ - -/* End of TKLISTBOX.C */ \ No newline at end of file +/* $Header$ */ + +/* + * tkListbox.c -- + * + * This module implements listbox widgets for the Tk + * toolkit. A listbox displays a collection of strings, + * one per line, and provides scrolling and selection. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tklistbox.c,v 1.1.1.1 2001/06/13 05:05:02 dtashley Exp $ + */ + +#include "tkPort.h" +#include "default.h" +#include "tkInt.h" + +typedef struct { + Tk_OptionTable listboxOptionTable; /* Table defining configuration options + * available for the listbox */ + Tk_OptionTable itemAttrOptionTable; /* Table definining configuration + * options available for listbox + * items */ +} ListboxOptionTables; + +/* + * A data structure of the following type is kept for each listbox + * widget managed by this file: + */ + +typedef struct { + Tk_Window tkwin; /* Window that embodies the listbox. NULL + * means that the window has been destroyed + * but the data structures haven't yet been + * cleaned up.*/ + Display *display; /* Display containing widget. Used, among + * other things, so that resources can be + * freed even after tkwin has gone away. */ + Tcl_Interp *interp; /* Interpreter associated with listbox. */ + Tcl_Command widgetCmd; /* Token for listbox's widget command. */ + Tk_OptionTable optionTable; /* Table that defines configuration options + * available for this widget. */ + Tk_OptionTable itemAttrOptionTable; /* Table that defines configuration + * options available for listbox + * items */ + char *listVarName; /* List variable name */ + Tcl_Obj *listObj; /* Pointer to the list object being used */ + int nElements; /* Holds the current count of elements */ + Tcl_HashTable *selection; /* Tracks selection */ + Tcl_HashTable *itemAttrTable; /* Tracks item attributes */ + + /* + * Information used when displaying widget: + */ + + Tk_3DBorder normalBorder; /* Used for drawing border around whole + * window, plus used for background. */ + int borderWidth; /* Width of 3-D border around window. */ + int relief; /* 3-D effect: TK_RELIEF_RAISED, etc. */ + int highlightWidth; /* Width in pixels of highlight to draw + * around widget when it has the focus. + * <= 0 means don't draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight + * area when highlight is off. */ + XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ + int inset; /* Total width of all borders, including + * traversal highlight and 3-D border. + * Indicates how much interior stuff must + * be offset from outside edges to leave + * room for borders. */ + Tk_Font tkfont; /* Information about text font, or NULL. */ + XColor *fgColorPtr; /* Text color in normal mode. */ + GC textGC; /* For drawing normal text. */ + Tk_3DBorder selBorder; /* Borders and backgrounds for selected + * elements. */ + int selBorderWidth; /* Width of border around selection. */ + XColor *selFgColorPtr; /* Foreground color for selected elements. */ + GC selTextGC; /* For drawing selected text. */ + int width; /* Desired width of window, in characters. */ + int height; /* Desired height of window, in lines. */ + int lineHeight; /* Number of pixels allocated for each line + * in display. */ + int topIndex; /* Index of top-most element visible in + * window. */ + int fullLines; /* Number of lines that fit are completely + * visible in window. There may be one + * additional line at the bottom that is + * partially visible. */ + int partialLine; /* 0 means that the window holds exactly + * fullLines lines. 1 means that there is + * one additional line that is partially + * visble. */ + int setGrid; /* Non-zero means pass gridding information + * to window manager. */ + + /* + * Information to support horizontal scrolling: + */ + + int maxWidth; /* Width (in pixels) of widest string in + * listbox. */ + int xScrollUnit; /* Number of pixels in one "unit" for + * horizontal scrolling (window scrolls + * horizontally in increments of this size). + * This is an average character size. */ + int xOffset; /* The left edge of each string in the + * listbox is offset to the left by this + * many pixels (0 means no offset, positive + * means there is an offset). */ + + /* + * Information about what's selected or active, if any. + */ + + Tk_Uid selectMode; /* Selection style: single, browse, multiple, + * or extended. This value isn't used in C + * code, but the Tcl bindings use it. */ + int numSelected; /* Number of elements currently selected. */ + int selectAnchor; /* Fixed end of selection (i.e. element + * at which selection was started.) */ + int exportSelection; /* Non-zero means tie internal listbox + * to X selection. */ + int active; /* Index of "active" element (the one that + * has been selected by keyboard traversal). + * -1 means none. */ + + /* + * Information for scanning: + */ + + int scanMarkX; /* X-position at which scan started (e.g. + * button was pressed here). */ + int scanMarkY; /* Y-position at which scan started (e.g. + * button was pressed here). */ + int scanMarkXOffset; /* Value of "xOffset" field when scan + * started. */ + int scanMarkYIndex; /* Index of line that was at top of window + * when scan started. */ + + /* + * Miscellaneous information: + */ + + Tk_Cursor cursor; /* Current cursor for window, or None. */ + char *takeFocus; /* Value of -takefocus option; not used in + * the C code, but used by keyboard traversal + * scripts. Malloc'ed, but may be NULL. */ + char *yScrollCmd; /* Command prefix for communicating with + * vertical scrollbar. NULL means no command + * to issue. Malloc'ed. */ + char *xScrollCmd; /* Command prefix for communicating with + * horizontal scrollbar. NULL means no command + * to issue. Malloc'ed. */ + int flags; /* Various flag bits: see below for + * definitions. */ +} Listbox; + +/* + * ItemAttr structures are used to store item configuration information for + * the items in a listbox + */ +typedef struct { + Tk_3DBorder border; /* Used for drawing background around text */ + Tk_3DBorder selBorder; /* Used for selected text */ + XColor *fgColor; /* Text color in normal mode. */ + XColor *selFgColor; /* Text color in selected mode. */ +} ItemAttr; + +/* + * Flag bits for listboxes: + * + * REDRAW_PENDING: Non-zero means a DoWhenIdle handler + * has already been queued to redraw + * this window. + * UPDATE_V_SCROLLBAR: Non-zero means vertical scrollbar needs + * to be updated. + * UPDATE_H_SCROLLBAR: Non-zero means horizontal scrollbar needs + * to be updated. + * GOT_FOCUS: Non-zero means this widget currently + * has the input focus. + * MAXWIDTH_IS_STALE: Stored maxWidth may be out-of-date + * LISTBOX_DELETED: This listbox has been effectively destroyed. + */ + +#define REDRAW_PENDING 1 +#define UPDATE_V_SCROLLBAR 2 +#define UPDATE_H_SCROLLBAR 4 +#define GOT_FOCUS 8 +#define MAXWIDTH_IS_STALE 16 +#define LISTBOX_DELETED 32 + +/* + * The optionSpecs table defines the valid configuration options for the + * listbox widget + */ +static Tk_OptionSpec optionSpecs[] = { + {TK_OPTION_BORDER, "-background", "background", "Background", + DEF_LISTBOX_BG_COLOR, -1, Tk_Offset(Listbox, normalBorder), + 0, (ClientData) DEF_LISTBOX_BG_MONO, 0}, + {TK_OPTION_SYNONYM, "-bd", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-borderwidth", 0}, + {TK_OPTION_SYNONYM, "-bg", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-background", 0}, + {TK_OPTION_PIXELS, "-borderwidth", "borderWidth", "BorderWidth", + DEF_LISTBOX_BORDER_WIDTH, -1, Tk_Offset(Listbox, borderWidth), + 0, 0, 0}, + {TK_OPTION_CURSOR, "-cursor", "cursor", "Cursor", + DEF_LISTBOX_CURSOR, -1, Tk_Offset(Listbox, cursor), + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_BOOLEAN, "-exportselection", "exportSelection", + "ExportSelection", DEF_LISTBOX_EXPORT_SELECTION, -1, + Tk_Offset(Listbox, exportSelection), 0, 0, 0}, + {TK_OPTION_SYNONYM, "-fg", "foreground", (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-foreground", 0}, + {TK_OPTION_FONT, "-font", "font", "Font", + DEF_LISTBOX_FONT, -1, Tk_Offset(Listbox, tkfont), 0, 0, 0}, + {TK_OPTION_COLOR, "-foreground", "foreground", "Foreground", + DEF_LISTBOX_FG, -1, Tk_Offset(Listbox, fgColorPtr), 0, 0, 0}, + {TK_OPTION_INT, "-height", "height", "Height", + DEF_LISTBOX_HEIGHT, -1, Tk_Offset(Listbox, height), 0, 0, 0}, + {TK_OPTION_COLOR, "-highlightbackground", "highlightBackground", + "HighlightBackground", DEF_LISTBOX_HIGHLIGHT_BG, -1, + Tk_Offset(Listbox, highlightBgColorPtr), 0, 0, 0}, + {TK_OPTION_COLOR, "-highlightcolor", "highlightColor", "HighlightColor", + DEF_LISTBOX_HIGHLIGHT, -1, Tk_Offset(Listbox, highlightColorPtr), + 0, 0, 0}, + {TK_OPTION_PIXELS, "-highlightthickness", "highlightThickness", + "HighlightThickness", DEF_LISTBOX_HIGHLIGHT_WIDTH, -1, + Tk_Offset(Listbox, highlightWidth), 0, 0, 0}, + {TK_OPTION_RELIEF, "-relief", "relief", "Relief", + DEF_LISTBOX_RELIEF, -1, Tk_Offset(Listbox, relief), 0, 0, 0}, + {TK_OPTION_BORDER, "-selectbackground", "selectBackground", "Foreground", + DEF_LISTBOX_SELECT_COLOR, -1, Tk_Offset(Listbox, selBorder), + 0, (ClientData) DEF_LISTBOX_SELECT_MONO, 0}, + {TK_OPTION_PIXELS, "-selectborderwidth", "selectBorderWidth", + "BorderWidth", DEF_LISTBOX_SELECT_BD, -1, + Tk_Offset(Listbox, selBorderWidth), 0, 0, 0}, + {TK_OPTION_COLOR, "-selectforeground", "selectForeground", "Background", + DEF_LISTBOX_SELECT_FG_COLOR, -1, Tk_Offset(Listbox, selFgColorPtr), + 0, (ClientData) DEF_LISTBOX_SELECT_FG_MONO, 0}, + {TK_OPTION_STRING, "-selectmode", "selectMode", "SelectMode", + DEF_LISTBOX_SELECT_MODE, -1, Tk_Offset(Listbox, selectMode), + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_BOOLEAN, "-setgrid", "setGrid", "SetGrid", + DEF_LISTBOX_SET_GRID, -1, Tk_Offset(Listbox, setGrid), 0, 0, 0}, + {TK_OPTION_STRING, "-takefocus", "takeFocus", "TakeFocus", + DEF_LISTBOX_TAKE_FOCUS, -1, Tk_Offset(Listbox, takeFocus), + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_INT, "-width", "width", "Width", + DEF_LISTBOX_WIDTH, -1, Tk_Offset(Listbox, width), 0, 0, 0}, + {TK_OPTION_STRING, "-xscrollcommand", "xScrollCommand", "ScrollCommand", + DEF_LISTBOX_SCROLL_COMMAND, -1, Tk_Offset(Listbox, xScrollCmd), + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_STRING, "-yscrollcommand", "yScrollCommand", "ScrollCommand", + DEF_LISTBOX_SCROLL_COMMAND, -1, Tk_Offset(Listbox, yScrollCmd), + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_STRING, "-listvariable", "listVariable", "Variable", + DEF_LISTBOX_LIST_VARIABLE, -1, Tk_Offset(Listbox, listVarName), + TK_OPTION_NULL_OK, 0, 0}, + {TK_OPTION_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, 0, 0} +}; + +/* + * The itemAttrOptionSpecs table defines the valid configuration options for + * listbox items + */ +static Tk_OptionSpec itemAttrOptionSpecs[] = { + {TK_OPTION_BORDER, "-background", "background", "Background", + (char *)NULL, -1, Tk_Offset(ItemAttr, border), + TK_OPTION_NULL_OK|TK_OPTION_DONT_SET_DEFAULT, + (ClientData) DEF_LISTBOX_BG_MONO, 0}, + {TK_OPTION_SYNONYM, "-bg", (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-background", 0}, + {TK_OPTION_SYNONYM, "-fg", "foreground", (char *) NULL, + (char *) NULL, 0, -1, 0, (ClientData) "-foreground", 0}, + {TK_OPTION_COLOR, "-foreground", "foreground", "Foreground", + (char *) NULL, -1, Tk_Offset(ItemAttr, fgColor), + TK_OPTION_NULL_OK|TK_OPTION_DONT_SET_DEFAULT, 0, 0}, + {TK_OPTION_BORDER, "-selectbackground", "selectBackground", "Foreground", + (char *) NULL, -1, Tk_Offset(ItemAttr, selBorder), + TK_OPTION_NULL_OK|TK_OPTION_DONT_SET_DEFAULT, + (ClientData) DEF_LISTBOX_SELECT_MONO, 0}, + {TK_OPTION_COLOR, "-selectforeground", "selectForeground", "Background", + (char *) NULL, -1, Tk_Offset(ItemAttr, selFgColor), + TK_OPTION_NULL_OK|TK_OPTION_DONT_SET_DEFAULT, + (ClientData) DEF_LISTBOX_SELECT_FG_MONO, 0}, + {TK_OPTION_END, (char *) NULL, (char *) NULL, (char *) NULL, + (char *) NULL, 0, -1, 0, 0, 0} +}; + +/* + * The following tables define the listbox widget commands (and sub- + * commands) and map the indexes into the string tables into + * enumerated types used to dispatch the listbox widget command. + */ +static char *commandNames[] = { + "activate", "bbox", "cget", "configure", "curselection", "delete", "get", + "index", "insert", "itemcget", "itemconfigure", "nearest", "scan", + "see", "selection", "size", "xview", "yview", + (char *) NULL +}; + +enum command { + COMMAND_ACTIVATE, COMMAND_BBOX, COMMAND_CGET, COMMAND_CONFIGURE, + COMMAND_CURSELECTION, COMMAND_DELETE, COMMAND_GET, COMMAND_INDEX, + COMMAND_INSERT, COMMAND_ITEMCGET, COMMAND_ITEMCONFIGURE, + COMMAND_NEAREST, COMMAND_SCAN, COMMAND_SEE, COMMAND_SELECTION, + COMMAND_SIZE, COMMAND_XVIEW, COMMAND_YVIEW +}; + +static char *selCommandNames[] = { + "anchor", "clear", "includes", "set", (char *) NULL +}; + +enum selcommand { + SELECTION_ANCHOR, SELECTION_CLEAR, SELECTION_INCLUDES, SELECTION_SET +}; + +static char *scanCommandNames[] = { + "mark", "dragto", (char *) NULL +}; + +enum scancommand { + SCAN_MARK, SCAN_DRAGTO +}; + +static char *indexNames[] = { + "active", "anchor", "end", (char *)NULL +}; + +enum indices { + INDEX_ACTIVE, INDEX_ANCHOR, INDEX_END +}; + + +/* Declarations for procedures defined later in this file */ +static void ChangeListboxOffset _ANSI_ARGS_((Listbox *listPtr, + int offset)); +static void ChangeListboxView _ANSI_ARGS_((Listbox *listPtr, + int index)); +static int ConfigureListbox _ANSI_ARGS_((Tcl_Interp *interp, + Listbox *listPtr, int objc, Tcl_Obj *CONST objv[], + int flags)); +static int ConfigureListboxItem _ANSI_ARGS_ ((Tcl_Interp *interp, + Listbox *listPtr, ItemAttr *attrs, int objc, + Tcl_Obj *CONST objv[])); +static int ListboxDeleteSubCmd _ANSI_ARGS_((Listbox *listPtr, + int first, int last)); +static void DestroyListbox _ANSI_ARGS_((char *memPtr)); +static void DestroyListboxOptionTables _ANSI_ARGS_ ( + (ClientData clientData, Tcl_Interp *interp)); +static void DisplayListbox _ANSI_ARGS_((ClientData clientData)); +static int GetListboxIndex _ANSI_ARGS_((Tcl_Interp *interp, + Listbox *listPtr, Tcl_Obj *index, int endIsSize, + int *indexPtr)); +static int ListboxInsertSubCmd _ANSI_ARGS_((Listbox *listPtr, + int index, int objc, Tcl_Obj *CONST objv[])); +static void ListboxCmdDeletedProc _ANSI_ARGS_(( + ClientData clientData)); +static void ListboxComputeGeometry _ANSI_ARGS_((Listbox *listPtr, + int fontChanged, int maxIsStale, int updateGrid)); +static void ListboxEventProc _ANSI_ARGS_((ClientData clientData, + XEvent *eventPtr)); +static int ListboxFetchSelection _ANSI_ARGS_(( + ClientData clientData, int offset, char *buffer, + int maxBytes)); +static void ListboxLostSelection _ANSI_ARGS_(( + ClientData clientData)); +static void EventuallyRedrawRange _ANSI_ARGS_((Listbox *listPtr, + int first, int last)); +static void ListboxScanTo _ANSI_ARGS_((Listbox *listPtr, + int x, int y)); +static int ListboxSelect _ANSI_ARGS_((Listbox *listPtr, + int first, int last, int select)); +static void ListboxUpdateHScrollbar _ANSI_ARGS_( + (Listbox *listPtr)); +static void ListboxUpdateVScrollbar _ANSI_ARGS_( + (Listbox *listPtr)); +static int ListboxWidgetObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *CONST objv[])); +static int ListboxBboxSubCmd _ANSI_ARGS_ ((Tcl_Interp *interp, + Listbox *listPtr, int index)); +static int ListboxSelectionSubCmd _ANSI_ARGS_ ( + (Tcl_Interp *interp, Listbox *listPtr, int objc, + Tcl_Obj *CONST objv[])); +static int ListboxXviewSubCmd _ANSI_ARGS_ ((Tcl_Interp *interp, + Listbox *listPtr, int objc, + Tcl_Obj *CONST objv[])); +static int ListboxYviewSubCmd _ANSI_ARGS_ ((Tcl_Interp *interp, + Listbox *listPtr, int objc, + Tcl_Obj *CONST objv[])); +static ItemAttr * ListboxGetItemAttributes _ANSI_ARGS_ ( + (Tcl_Interp *interp, Listbox *listPtr, int index)); +static void ListboxWorldChanged _ANSI_ARGS_(( + ClientData instanceData)); +static int NearestListboxElement _ANSI_ARGS_((Listbox *listPtr, + int y)); +static char * ListboxListVarProc _ANSI_ARGS_ ((ClientData clientData, + Tcl_Interp *interp, char *name1, char *name2, + int flags)); +static void MigrateHashEntries _ANSI_ARGS_ ((Tcl_HashTable *table, + int first, int last, int offset)); +/* + * The structure below defines button class behavior by means of procedures + * that can be invoked from generic window code. + */ + +static TkClassProcs listboxClass = { + NULL, /* createProc. */ + ListboxWorldChanged, /* geometryProc. */ + NULL /* modalProc. */ +}; + + +/* + *-------------------------------------------------------------- + * + * Tk_ListboxObjCmd -- + * + * This procedure is invoked to process the "listbox" Tcl + * command. See the user documentation for details on what + * it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *-------------------------------------------------------------- + */ + +int +Tk_ListboxObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Either NULL or pointer to option table */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Argument objects. */ +{ + register Listbox *listPtr; + Tk_Window tkwin; + ListboxOptionTables *optionTables; + + optionTables = (ListboxOptionTables *)clientData; + if (optionTables == NULL) { + Tcl_CmdInfo info; + char *name; + + /* + * We haven't created the option tables for this widget class yet. + * Do it now and save the a pointer to them as the ClientData for + * the command, so future invocations will have access to it. + */ + optionTables = + (ListboxOptionTables *) ckalloc(sizeof(ListboxOptionTables)); + /* Set up an exit handler to free the optionTables struct */ + Tcl_SetAssocData(interp, "ListboxOptionTables", + DestroyListboxOptionTables, (ClientData) optionTables); + + /* Create the listbox option table and the listbox item option table */ + optionTables->listboxOptionTable = + Tk_CreateOptionTable(interp, optionSpecs); + optionTables->itemAttrOptionTable = + Tk_CreateOptionTable(interp, itemAttrOptionSpecs); + + /* Store a pointer to the tables as the ClientData for the command */ + name = Tcl_GetString(objv[0]); + Tcl_GetCommandInfo(interp, name, &info); + info.objClientData = (ClientData) optionTables; + Tcl_SetCommandInfo(interp, name, &info); + } + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "pathName ?options?"); + return TCL_ERROR; + } + + tkwin = Tk_CreateWindowFromPath(interp, Tk_MainWindow(interp), + Tcl_GetString(objv[1]), (char *) NULL); + if (tkwin == NULL) { + return TCL_ERROR; + } + + /* + * Initialize the fields of the structure that won't be initialized + * by ConfigureListbox, or that ConfigureListbox requires to be + * initialized already (e.g. resource pointers). + */ + listPtr = (Listbox *) ckalloc(sizeof(Listbox)); + listPtr->tkwin = tkwin; + listPtr->display = Tk_Display(tkwin); + listPtr->interp = interp; + listPtr->widgetCmd = Tcl_CreateObjCommand(interp, + Tk_PathName(listPtr->tkwin), ListboxWidgetObjCmd, + (ClientData) listPtr, ListboxCmdDeletedProc); + listPtr->optionTable = optionTables->listboxOptionTable; + listPtr->itemAttrOptionTable = optionTables->itemAttrOptionTable; + listPtr->listVarName = NULL; + listPtr->listObj = NULL; + listPtr->selection = + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(listPtr->selection, TCL_ONE_WORD_KEYS); + listPtr->itemAttrTable = + (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(listPtr->itemAttrTable, TCL_ONE_WORD_KEYS); + listPtr->nElements = 0; + listPtr->normalBorder = NULL; + listPtr->borderWidth = 0; + listPtr->relief = TK_RELIEF_RAISED; + listPtr->highlightWidth = 0; + listPtr->highlightBgColorPtr = NULL; + listPtr->highlightColorPtr = NULL; + listPtr->inset = 0; + listPtr->tkfont = NULL; + listPtr->fgColorPtr = NULL; + listPtr->textGC = None; + listPtr->selBorder = NULL; + listPtr->selBorderWidth = 0; + listPtr->selFgColorPtr = None; + listPtr->selTextGC = None; + listPtr->width = 0; + listPtr->height = 0; + listPtr->lineHeight = 0; + listPtr->topIndex = 0; + listPtr->fullLines = 1; + listPtr->partialLine = 0; + listPtr->setGrid = 0; + listPtr->maxWidth = 0; + listPtr->xScrollUnit = 1; + listPtr->xOffset = 0; + listPtr->selectMode = NULL; + listPtr->numSelected = 0; + listPtr->selectAnchor = 0; + listPtr->exportSelection = 1; + listPtr->active = 0; + listPtr->scanMarkX = 0; + listPtr->scanMarkY = 0; + listPtr->scanMarkXOffset = 0; + listPtr->scanMarkYIndex = 0; + listPtr->cursor = None; + listPtr->takeFocus = NULL; + listPtr->xScrollCmd = NULL; + listPtr->yScrollCmd = NULL; + listPtr->flags = 0; + + Tk_SetClass(listPtr->tkwin, "Listbox"); + TkSetClassProcs(listPtr->tkwin, &listboxClass, (ClientData) listPtr); + Tk_CreateEventHandler(listPtr->tkwin, + ExposureMask|StructureNotifyMask|FocusChangeMask, + ListboxEventProc, (ClientData) listPtr); + Tk_CreateSelHandler(listPtr->tkwin, XA_PRIMARY, XA_STRING, + ListboxFetchSelection, (ClientData) listPtr, XA_STRING); + if (Tk_InitOptions(interp, (char *)listPtr, + optionTables->listboxOptionTable, tkwin) != TCL_OK) { + Tk_DestroyWindow(listPtr->tkwin); + return TCL_ERROR; + } + + if (ConfigureListbox(interp, listPtr, objc-2, objv+2, 0) != TCL_OK) { + Tk_DestroyWindow(listPtr->tkwin); + return TCL_ERROR; + } + + Tcl_SetResult(interp, Tk_PathName(listPtr->tkwin), TCL_STATIC); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ListboxWidgetObjCmd -- + * + * This Tcl_Obj based procedure is invoked to process the Tcl command + * that corresponds to a 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. + * + *---------------------------------------------------------------------- + */ + +static int +ListboxWidgetObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Information about listbox widget. */ + Tcl_Interp *interp; /* Current interpreter. */ + int objc; /* Number of arguments. */ + Tcl_Obj *CONST objv[]; /* Arguments as Tcl_Obj's. */ +{ + register Listbox *listPtr = (Listbox *) clientData; + int cmdIndex, index; + int result = TCL_OK; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + return TCL_ERROR; + } + Tcl_Preserve((ClientData)listPtr); + + /* + * Parse the command by looking up the second argument in the list + * of valid subcommand names + */ + result = Tcl_GetIndexFromObj(interp, objv[1], commandNames, + "option", 0, &cmdIndex); + if (result != TCL_OK) { + Tcl_Release((ClientData)listPtr); + return result; + } + + /* The subcommand was valid, so continue processing */ + switch (cmdIndex) { + case COMMAND_ACTIVATE: { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "index"); + result = TCL_ERROR; + break; + } + result = GetListboxIndex(interp, listPtr, objv[2], 0, &index); + if (result != TCL_OK) { + break; + } + if (index >= listPtr->nElements) { + index = listPtr->nElements-1; + } + if (index < 0) { + index = 0; + } + listPtr->active = index; + EventuallyRedrawRange(listPtr, listPtr->active, listPtr->active); + result = TCL_OK; + break; + } + + case COMMAND_BBOX: { + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "index"); + result = TCL_ERROR; + break; + } + result = GetListboxIndex(interp, listPtr, objv[2], 0, &index); + if (result != TCL_OK) { + break; + } + + result = ListboxBboxSubCmd(interp, listPtr, index); + break; + } + + case COMMAND_CGET: { + Tcl_Obj *objPtr; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "option"); + result = TCL_ERROR; + break; + } + + objPtr = Tk_GetOptionValue(interp, (char *)listPtr, + listPtr->optionTable, objv[2], listPtr->tkwin); + if (objPtr == NULL) { + result = TCL_ERROR; + break; + } + Tcl_SetObjResult(interp, objPtr); + result = TCL_OK; + break; + } + + case COMMAND_CONFIGURE: { + Tcl_Obj *objPtr; + if (objc <= 3) { + objPtr = Tk_GetOptionInfo(interp, (char *) listPtr, + listPtr->optionTable, + (objc == 3) ? objv[2] : (Tcl_Obj *) NULL, + listPtr->tkwin); + if (objPtr == NULL) { + result = TCL_ERROR; + break; + } else { + Tcl_SetObjResult(interp, objPtr); + result = TCL_OK; + } + } else { + result = ConfigureListbox(interp, listPtr, objc-2, objv+2, 0); + } + break; + } + + case COMMAND_CURSELECTION: { + char indexStringRep[TCL_INTEGER_SPACE]; + int i; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + result = TCL_ERROR; + break; + } + /* + * Of course, it would be more efficient to use the Tcl_HashTable + * search functions (Tcl_FirstHashEntry, Tcl_NextHashEntry), but + * then the result wouldn't be in sorted order. So instead we + * loop through the indices in order, adding them to the result + * if they are selected + */ + for (i = 0; i < listPtr->nElements; i++) { + if (Tcl_FindHashEntry(listPtr->selection, (char *)i) != NULL) { + sprintf(indexStringRep, "%d", i); + Tcl_AppendElement(interp, indexStringRep); + } + } + result = TCL_OK; + break; + } + + case COMMAND_DELETE: { + int first, last; + if ((objc < 3) || (objc > 4)) { + Tcl_WrongNumArgs(interp, 2, objv, + "firstIndex ?lastIndex?"); + result = TCL_ERROR; + break; + } + + result = GetListboxIndex(interp, listPtr, objv[2], 0, &first); + if (result != TCL_OK) { + break; + } + if (first < listPtr->nElements) { + /* + * if a "last index" was given, get it now; otherwise, use the + * first index as the last index + */ + if (objc == 4) { + result = GetListboxIndex(interp, listPtr, + objv[3], 0, &last); + if (result != TCL_OK) { + break; + } + } else { + last = first; + } + if (last >= listPtr->nElements) { + last = listPtr->nElements - 1; + } + result = ListboxDeleteSubCmd(listPtr, first, last); + } else { + result = TCL_OK; + } + break; + } + + case COMMAND_GET: { + int first, last; + Tcl_Obj **elemPtrs; + int listLen; + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "firstIndex ?lastIndex?"); + result = TCL_ERROR; + break; + } + result = GetListboxIndex(interp, listPtr, objv[2], 0, &first); + if (result != TCL_OK) { + break; + } + last = first; + if (objc == 4) { + result = GetListboxIndex(interp, listPtr, objv[3], 0, &last); + if (result != TCL_OK) { + break; + } + } + if (first >= listPtr->nElements) { + result = TCL_OK; + break; + } + if (last >= listPtr->nElements) { + last = listPtr->nElements - 1; + } + if (first < 0) { + first = 0; + } + if (first > last) { + result = TCL_OK; + break; + } + result = Tcl_ListObjGetElements(interp, listPtr->listObj, &listLen, + &elemPtrs); + if (result != TCL_OK) { + break; + } + if (objc == 3) { + /* + * One element request - we return a string + */ + Tcl_SetObjResult(interp, elemPtrs[first]); + } else { + Tcl_SetListObj(Tcl_GetObjResult(interp), (last - first + 1), + &(elemPtrs[first])); + } + result = TCL_OK; + break; + } + + case COMMAND_INDEX:{ + char buf[TCL_INTEGER_SPACE]; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "index"); + result = TCL_ERROR; + break; + } + result = GetListboxIndex(interp, listPtr, objv[2], 1, &index); + if (result != TCL_OK) { + break; + } + sprintf(buf, "%d", index); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + result = TCL_OK; + break; + } + + case COMMAND_INSERT: { + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, + "index ?element element ...?"); + result = TCL_ERROR; + break; + } + + result = GetListboxIndex(interp, listPtr, objv[2], 1, &index); + if (result != TCL_OK) { + break; + } + result = ListboxInsertSubCmd(listPtr, index, objc-3, objv+3); + break; + } + + case COMMAND_ITEMCGET: { + Tcl_Obj *objPtr; + ItemAttr *attrPtr; + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "index option"); + result = TCL_ERROR; + break; + } + + result = GetListboxIndex(interp, listPtr, objv[2], 0, &index); + if (result != TCL_OK) { + break; + } + + if (index < 0 || index >= listPtr->nElements) { + Tcl_AppendResult(interp, "item number \"", + Tcl_GetString(objv[2]), "\" out of range", + (char *)NULL); + result = TCL_ERROR; + break; + } + + attrPtr = ListboxGetItemAttributes(interp, listPtr, index); + + objPtr = Tk_GetOptionValue(interp, (char *)attrPtr, + listPtr->itemAttrOptionTable, objv[3], listPtr->tkwin); + if (objPtr == NULL) { + result = TCL_ERROR; + break; + } + Tcl_SetObjResult(interp, objPtr); + result = TCL_OK; + break; + } + + case COMMAND_ITEMCONFIGURE: { + Tcl_Obj *objPtr; + ItemAttr *attrPtr; + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, + "index ?option? ?value? ?option value ...?"); + result = TCL_ERROR; + break; + } + + result = GetListboxIndex(interp, listPtr, objv[2], 0, &index); + if (result != TCL_OK) { + break; + } + + if (index < 0 || index >= listPtr->nElements) { + Tcl_AppendResult(interp, "item number \"", + Tcl_GetString(objv[2]), "\" out of range", + (char *)NULL); + result = TCL_ERROR; + break; + } + + attrPtr = ListboxGetItemAttributes(interp, listPtr, index); + if (objc <= 4) { + objPtr = Tk_GetOptionInfo(interp, (char *)attrPtr, + listPtr->itemAttrOptionTable, + (objc == 4) ? objv[3] : (Tcl_Obj *) NULL, + listPtr->tkwin); + if (objPtr == NULL) { + result = TCL_ERROR; + break; + } else { + Tcl_SetObjResult(interp, objPtr); + result = TCL_OK; + } + } else { + result = ConfigureListboxItem(interp, listPtr, attrPtr, + objc-3, objv+3); + } + break; + } + + case COMMAND_NEAREST: { + char buf[TCL_INTEGER_SPACE]; + int y; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "y"); + result = TCL_ERROR; + break; + } + + result = Tcl_GetIntFromObj(interp, objv[2], &y); + if (result != TCL_OK) { + break; + } + index = NearestListboxElement(listPtr, y); + sprintf(buf, "%d", index); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + result = TCL_OK; + break; + } + + case COMMAND_SCAN: { + int x, y, scanCmdIndex; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "mark|dragto x y"); + result = TCL_ERROR; + break; + } + + if (Tcl_GetIntFromObj(interp, objv[3], &x) != TCL_OK + || Tcl_GetIntFromObj(interp, objv[4], &y) != TCL_OK) { + result = TCL_ERROR; + break; + } + + result = Tcl_GetIndexFromObj(interp, objv[2], scanCommandNames, + "option", 0, &scanCmdIndex); + if (result != TCL_OK) { + break; + } + switch (scanCmdIndex) { + case SCAN_MARK: { + listPtr->scanMarkX = x; + listPtr->scanMarkY = y; + listPtr->scanMarkXOffset = listPtr->xOffset; + listPtr->scanMarkYIndex = listPtr->topIndex; + break; + } + case SCAN_DRAGTO: { + ListboxScanTo(listPtr, x, y); + break; + } + } + result = TCL_OK; + break; + } + + case COMMAND_SEE: { + int diff; + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "index"); + result = TCL_ERROR; + break; + } + result = GetListboxIndex(interp, listPtr, objv[2], 0, &index); + if (result != TCL_OK) { + break; + } + if (index >= listPtr->nElements) { + index = listPtr->nElements - 1; + } + if (index < 0) { + index = 0; + } + diff = listPtr->topIndex - index; + if (diff > 0) { + if (diff <= (listPtr->fullLines/3)) { + ChangeListboxView(listPtr, index); + } else { + ChangeListboxView(listPtr, + index - (listPtr->fullLines-1)/2); + } + } else { + diff = index - (listPtr->topIndex + listPtr->fullLines - 1); + if (diff > 0) { + if (diff <= (listPtr->fullLines/3)) { + ChangeListboxView(listPtr, listPtr->topIndex + diff); + } else { + ChangeListboxView(listPtr, + index - (listPtr->fullLines-1)/2); + } + } + } + result = TCL_OK; + break; + } + + case COMMAND_SELECTION: { + result = ListboxSelectionSubCmd(interp, listPtr, objc, objv); + break; + } + + case COMMAND_SIZE: { + char buf[TCL_INTEGER_SPACE]; + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, NULL); + result = TCL_ERROR; + break; + } + sprintf(buf, "%d", listPtr->nElements); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + result = TCL_OK; + break; + } + + case COMMAND_XVIEW: { + result = ListboxXviewSubCmd(interp, listPtr, objc, objv); + break; + } + + case COMMAND_YVIEW: { + result = ListboxYviewSubCmd(interp, listPtr, objc, objv); + break; + } + } + Tcl_Release((ClientData)listPtr); + return result; +} + +/* + *---------------------------------------------------------------------- + * + * ListboxBboxSubCmd -- + * + * This procedure is invoked to process a listbox bbox request. + * See the user documentation for more information. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * For valid indices, places the bbox of the requested element in + * the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +static int +ListboxBboxSubCmd(interp, listPtr, index) + Tcl_Interp *interp; /* Pointer to the calling Tcl interpreter */ + Listbox *listPtr; /* Information about the listbox */ + int index; /* Index of the element to get bbox info on */ +{ + int lastVisibleIndex; + /* Determine the index of the last visible item in the listbox */ + lastVisibleIndex = listPtr->topIndex + listPtr->fullLines + + listPtr->partialLine; + if (listPtr->nElements < lastVisibleIndex) { + lastVisibleIndex = listPtr->nElements; + } + + /* Only allow bbox requests for indices that are visible */ + if ((listPtr->topIndex <= index) && (index < lastVisibleIndex)) { + char buf[TCL_INTEGER_SPACE * 4]; + Tcl_Obj *el; + char *stringRep; + int pixelWidth, stringLen, x, y, result; + Tk_FontMetrics fm; + + /* Compute the pixel width of the requested element */ + result = Tcl_ListObjIndex(interp, listPtr->listObj, index, &el); + if (result != TCL_OK) { + return result; + } + + stringRep = Tcl_GetStringFromObj(el, &stringLen); + Tk_GetFontMetrics(listPtr->tkfont, &fm); + pixelWidth = Tk_TextWidth(listPtr->tkfont, stringRep, stringLen); + + x = listPtr->inset + listPtr->selBorderWidth - listPtr->xOffset; + y = ((index - listPtr->topIndex)*listPtr->lineHeight) + + listPtr->inset + listPtr->selBorderWidth; + sprintf(buf, "%d %d %d %d", x, y, pixelWidth, fm.linespace); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ListboxSelectionSubCmd -- + * + * This procedure is invoked to process the selection sub command + * for listbox widgets. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * May set the interpreter's result field. + * + *---------------------------------------------------------------------- + */ + +static int +ListboxSelectionSubCmd(interp, listPtr, objc, objv) + Tcl_Interp *interp; /* Pointer to the calling Tcl interpreter */ + Listbox *listPtr; /* Information about the listbox */ + int objc; /* Number of arguments in the objv array */ + Tcl_Obj *CONST objv[]; /* Array of arguments to the procedure */ +{ + int selCmdIndex, first, last; + int result = TCL_OK; + if (objc != 4 && objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "option index ?index?"); + return TCL_ERROR; + } + result = GetListboxIndex(interp, listPtr, objv[3], 0, &first); + if (result != TCL_OK) { + return result; + } + last = first; + if (objc == 5) { + result = GetListboxIndex(interp, listPtr, objv[4], 0, &last); + if (result != TCL_OK) { + return result; + } + } + result = Tcl_GetIndexFromObj(interp, objv[2], selCommandNames, + "option", 0, &selCmdIndex); + if (result != TCL_OK) { + return result; + } + switch (selCmdIndex) { + case SELECTION_ANCHOR: { + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "index"); + return TCL_ERROR; + } + if (first >= listPtr->nElements) { + first = listPtr->nElements - 1; + } + if (first < 0) { + first = 0; + } + listPtr->selectAnchor = first; + result = TCL_OK; + break; + } + case SELECTION_CLEAR: { + result = ListboxSelect(listPtr, first, last, 0); + break; + } + case SELECTION_INCLUDES: { + if (objc != 4) { + Tcl_WrongNumArgs(interp, 3, objv, "index"); + return TCL_ERROR; + } + if (Tcl_FindHashEntry(listPtr->selection, (char *)first)) { + Tcl_SetResult(interp, "1", TCL_STATIC); + } else { + Tcl_SetResult(interp, "0", TCL_STATIC); + } + result = TCL_OK; + break; + } + case SELECTION_SET: { + result = ListboxSelect(listPtr, first, last, 1); + break; + } + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * ListboxXviewSubCmd -- + * + * Process the listbox "xview" subcommand. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * May change the listbox viewing area; may set the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +static int +ListboxXviewSubCmd(interp, listPtr, objc, objv) + Tcl_Interp *interp; /* Pointer to the calling Tcl interpreter */ + Listbox *listPtr; /* Information about the listbox */ + int objc; /* Number of arguments in the objv array */ + Tcl_Obj *CONST objv[]; /* Array of arguments to the procedure */ +{ + + int index, count, type, windowWidth, windowUnits; + int offset = 0; /* Initialized to stop gcc warnings. */ + double fraction, fraction2; + + windowWidth = Tk_Width(listPtr->tkwin) + - 2*(listPtr->inset + listPtr->selBorderWidth); + if (objc == 2) { + if (listPtr->maxWidth == 0) { + Tcl_SetResult(interp, "0 1", TCL_STATIC); + } else { + char buf[TCL_DOUBLE_SPACE * 2]; + + fraction = listPtr->xOffset/((double) listPtr->maxWidth); + fraction2 = (listPtr->xOffset + windowWidth) + /((double) listPtr->maxWidth); + if (fraction2 > 1.0) { + fraction2 = 1.0; + } + sprintf(buf, "%g %g", fraction, fraction2); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } + } else if (objc == 3) { + if (Tcl_GetIntFromObj(interp, objv[2], &index) != TCL_OK) { + return TCL_ERROR; + } + ChangeListboxOffset(listPtr, index*listPtr->xScrollUnit); + } else { + type = Tk_GetScrollInfoObj(interp, objc, objv, &fraction, &count); + switch (type) { + case TK_SCROLL_ERROR: + return TCL_ERROR; + case TK_SCROLL_MOVETO: + offset = (int) (fraction*listPtr->maxWidth + 0.5); + break; + case TK_SCROLL_PAGES: + windowUnits = windowWidth/listPtr->xScrollUnit; + if (windowUnits > 2) { + offset = listPtr->xOffset + + count*listPtr->xScrollUnit*(windowUnits-2); + } else { + offset = listPtr->xOffset + count*listPtr->xScrollUnit; + } + break; + case TK_SCROLL_UNITS: + offset = listPtr->xOffset + count*listPtr->xScrollUnit; + break; + } + ChangeListboxOffset(listPtr, offset); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ListboxYviewSubCmd -- + * + * Process the listbox "yview" subcommand. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * May change the listbox viewing area; may set the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +static int +ListboxYviewSubCmd(interp, listPtr, objc, objv) + Tcl_Interp *interp; /* Pointer to the calling Tcl interpreter */ + Listbox *listPtr; /* Information about the listbox */ + int objc; /* Number of arguments in the objv array */ + Tcl_Obj *CONST objv[]; /* Array of arguments to the procedure */ +{ + int index, count, type; + double fraction, fraction2; + + if (objc == 2) { + if (listPtr->nElements == 0) { + Tcl_SetResult(interp, "0 1", TCL_STATIC); + } else { + char buf[TCL_DOUBLE_SPACE * 2]; + + fraction = listPtr->topIndex/((double) listPtr->nElements); + fraction2 = (listPtr->topIndex+listPtr->fullLines) + /((double) listPtr->nElements); + if (fraction2 > 1.0) { + fraction2 = 1.0; + } + sprintf(buf, "%g %g", fraction, fraction2); + Tcl_SetResult(interp, buf, TCL_VOLATILE); + } + } else if (objc == 3) { + if (GetListboxIndex(interp, listPtr, objv[2], 0, &index) != TCL_OK) { + return TCL_ERROR; + } + ChangeListboxView(listPtr, index); + } else { + type = Tk_GetScrollInfoObj(interp, objc, objv, &fraction, &count); + switch (type) { + case TK_SCROLL_ERROR: + return TCL_ERROR; + case TK_SCROLL_MOVETO: + index = (int) (listPtr->nElements*fraction + 0.5); + break; + case TK_SCROLL_PAGES: + if (listPtr->fullLines > 2) { + index = listPtr->topIndex + + count*(listPtr->fullLines-2); + } else { + index = listPtr->topIndex + count; + } + break; + case TK_SCROLL_UNITS: + index = listPtr->topIndex + count; + break; + } + ChangeListboxView(listPtr, index); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ListboxGetItemAttributes -- + * + * Returns a pointer to the ItemAttr record for a given index, + * creating one if it does not already exist. + * + * Results: + * Pointer to an ItemAttr record. + * + * Side effects: + * Memory may be allocated for the ItemAttr record. + * + *---------------------------------------------------------------------- + */ + +static ItemAttr * +ListboxGetItemAttributes(interp, listPtr, index) + Tcl_Interp *interp; /* Pointer to the calling Tcl interpreter */ + Listbox *listPtr; /* Information about the listbox */ + int index; /* Index of the item to retrieve attributes + * for */ +{ + int new; + Tcl_HashEntry *entry; + ItemAttr *attrs; + + entry = Tcl_CreateHashEntry(listPtr->itemAttrTable, (char *)index, + &new); + if (new) { + attrs = (ItemAttr *) ckalloc(sizeof(ItemAttr)); + attrs->border = NULL; + attrs->selBorder = NULL; + attrs->fgColor = NULL; + attrs->selFgColor = NULL; + Tk_InitOptions(interp, (char *)attrs, listPtr->itemAttrOptionTable, + listPtr->tkwin); + Tcl_SetHashValue(entry, (ClientData) attrs); + } + attrs = (ItemAttr *)Tcl_GetHashValue(entry); + return attrs; +} + +/* + *---------------------------------------------------------------------- + * + * DestroyListbox -- + * + * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release + * to clean up the internal structure of a listbox at a safe time + * (when no-one is using it anymore). + * + * Results: + * None. + * + * Side effects: + * Everything associated with the listbox is freed up. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyListbox(memPtr) + char *memPtr; /* Info about listbox widget. */ +{ + register Listbox *listPtr = (Listbox *) memPtr; + Tcl_HashEntry *entry; + Tcl_HashSearch search; + + listPtr->flags |= LISTBOX_DELETED; + + Tcl_DeleteCommandFromToken(listPtr->interp, listPtr->widgetCmd); + if (listPtr->setGrid) { + Tk_UnsetGrid(listPtr->tkwin); + } + if (listPtr->flags & REDRAW_PENDING) { + Tcl_CancelIdleCall(DisplayListbox, (ClientData) listPtr); + } + + /* If we have an internal list object, free it */ + if (listPtr->listObj != NULL) { + Tcl_DecrRefCount(listPtr->listObj); + listPtr->listObj = NULL; + } + + if (listPtr->listVarName != NULL) { + Tcl_UntraceVar(listPtr->interp, listPtr->listVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ListboxListVarProc, (ClientData) listPtr); + } + + /* Free the selection hash table */ + Tcl_DeleteHashTable(listPtr->selection); + ckfree((char *)listPtr->selection); + + /* Free the item attribute hash table */ + for (entry = Tcl_FirstHashEntry(listPtr->itemAttrTable, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + ckfree((char *)Tcl_GetHashValue(entry)); + } + Tcl_DeleteHashTable(listPtr->itemAttrTable); + ckfree((char *)listPtr->itemAttrTable); + + /* + * Free up all the stuff that requires special handling, then + * let Tk_FreeOptions handle all the standard option-related + * stuff. + */ + + if (listPtr->textGC != None) { + Tk_FreeGC(listPtr->display, listPtr->textGC); + } + if (listPtr->selTextGC != None) { + Tk_FreeGC(listPtr->display, listPtr->selTextGC); + } + Tk_FreeConfigOptions((char *)listPtr, listPtr->optionTable, + listPtr->tkwin); + listPtr->tkwin = NULL; + ckfree((char *) listPtr); +} + +/* + *---------------------------------------------------------------------- + * + * DestroyListboxOptionTables -- + * + * This procedure is registered as an exit callback when the listbox + * command is first called. It cleans up the OptionTables structure + * allocated by that command. + * + * Results: + * None. + * + * Side effects: + * Frees memory. + * + *---------------------------------------------------------------------- + */ + +static void +DestroyListboxOptionTables(clientData, interp) + ClientData clientData; /* Pointer to the OptionTables struct */ + Tcl_Interp *interp; /* Pointer to the calling interp */ +{ + ckfree((char *)clientData); + return; +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureListbox -- + * + * This procedure is called to process an objv/objc list, plus + * the Tk option database, in order to configure (or reconfigure) + * a listbox widget. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then the interp's result contains an error message. + * + * Side effects: + * Configuration information, such as colors, border width, + * etc. get set for listPtr; old resources get freed, + * if there were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureListbox(interp, listPtr, objc, objv, flags) + Tcl_Interp *interp; /* Used for error reporting. */ + register Listbox *listPtr; /* Information about widget; may or may + * not already have values for some fields. */ + int objc; /* Number of valid entries in argv. */ + Tcl_Obj *CONST objv[]; /* Arguments. */ + int flags; /* Flags to pass to Tk_ConfigureWidget. */ +{ + Tk_SavedOptions savedOptions; + Tcl_Obj *oldListObj = NULL; + int oldExport; + + oldExport = listPtr->exportSelection; + if (listPtr->listVarName != NULL) { + Tcl_UntraceVar(interp, listPtr->listVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ListboxListVarProc, (ClientData) listPtr); + } + + if (Tk_SetOptions(interp, (char *)listPtr, + listPtr->optionTable, objc, objv, listPtr->tkwin, + &savedOptions, (int *)NULL) != TCL_OK) { + Tk_RestoreSavedOptions(&savedOptions); + return TCL_ERROR; + } + + /* + * A few options need special processing, such as setting the + * background from a 3-D border. + */ + + Tk_SetBackgroundFromBorder(listPtr->tkwin, listPtr->normalBorder); + + if (listPtr->highlightWidth < 0) { + listPtr->highlightWidth = 0; + } + listPtr->inset = listPtr->highlightWidth + listPtr->borderWidth; + + /* + * Claim the selection if we've suddenly started exporting it and + * there is a selection to export. + */ + + if (listPtr->exportSelection && !oldExport + && (listPtr->numSelected != 0)) { + Tk_OwnSelection(listPtr->tkwin, XA_PRIMARY, ListboxLostSelection, + (ClientData) listPtr); + } + + + /* Verify the current status of the list var. + * PREVIOUS STATE | NEW STATE | ACTION + * ------------------+---------------+---------------------------------- + * no listvar | listvar | If listvar does not exist, create + * it and copy the internal list obj's + * content to the new var. If it does + * exist, toss the internal list obj. + * + * listvar | no listvar | Copy old listvar content to the + * internal list obj + * + * listvar | listvar | no special action + * + * no listvar | no listvar | no special action + */ + oldListObj = listPtr->listObj; + if (listPtr->listVarName != NULL) { + Tcl_Obj *listVarObj = Tcl_GetVar2Ex(interp, listPtr->listVarName, + (char *)NULL, TCL_GLOBAL_ONLY); + int dummy; + if (listVarObj == NULL) { + if (listPtr->listObj != NULL) { + listVarObj = listPtr->listObj; + } else { + listVarObj = Tcl_NewObj(); + } + if (Tcl_SetVar2Ex(interp, listPtr->listVarName, (char *)NULL, + listVarObj, TCL_GLOBAL_ONLY) == NULL) { + Tcl_DecrRefCount(listVarObj); + Tk_RestoreSavedOptions(&savedOptions); + return TCL_ERROR; + } + } + /* Make sure the object is a good list object */ + if (Tcl_ListObjLength(listPtr->interp, listVarObj, &dummy) != TCL_OK) { + Tk_RestoreSavedOptions(&savedOptions); + Tcl_AppendResult(listPtr->interp, ": invalid listvar value", + (char *)NULL); + return TCL_ERROR; + } + + listPtr->listObj = listVarObj; + Tcl_TraceVar(listPtr->interp, listPtr->listVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ListboxListVarProc, (ClientData) listPtr); + } else { + if (listPtr->listObj == NULL) { + listPtr->listObj = Tcl_NewObj(); + } + } + Tcl_IncrRefCount(listPtr->listObj); + if (oldListObj != NULL) { + Tcl_DecrRefCount(oldListObj); + } + + /* Make sure that the list length is correct */ + Tcl_ListObjLength(listPtr->interp, listPtr->listObj, &listPtr->nElements); + + Tk_FreeSavedOptions(&savedOptions); + ListboxWorldChanged((ClientData) listPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ConfigureListboxItem -- + * + * This procedure is called to process an objv/objc list, plus + * the Tk option database, in order to configure (or reconfigure) + * a listbox item. + * + * Results: + * The return value is a standard Tcl result. If TCL_ERROR is + * returned, then the interp's result contains an error message. + * + * Side effects: + * Configuration information, such as colors, border width, + * etc. get set for a listbox item; old resources get freed, + * if there were any. + * + *---------------------------------------------------------------------- + */ + +static int +ConfigureListboxItem(interp, listPtr, attrs, objc, objv) + Tcl_Interp *interp; /* Used for error reporting. */ + register Listbox *listPtr; /* Information about widget; may or may + * not already have values for some fields. */ + ItemAttr *attrs; /* Information about the item to configure */ + int objc; /* Number of valid entries in argv. */ + Tcl_Obj *CONST objv[]; /* Arguments. */ +{ + Tk_SavedOptions savedOptions; + + if (Tk_SetOptions(interp, (char *)attrs, + listPtr->itemAttrOptionTable, objc, objv, listPtr->tkwin, + &savedOptions, (int *)NULL) != TCL_OK) { + Tk_RestoreSavedOptions(&savedOptions); + return TCL_ERROR; + } + Tk_FreeSavedOptions(&savedOptions); + ListboxWorldChanged((ClientData) listPtr); + return TCL_OK; +} + +/* + *--------------------------------------------------------------------------- + * + * ListboxWorldChanged -- + * + * This procedure is called when the world has changed in some + * way and the widget needs to recompute all its graphics contexts + * and determine its new geometry. + * + * Results: + * None. + * + * Side effects: + * Listbox will be relayed out and redisplayed. + * + *--------------------------------------------------------------------------- + */ + +static void +ListboxWorldChanged(instanceData) + ClientData instanceData; /* Information about widget. */ +{ + XGCValues gcValues; + GC gc; + unsigned long mask; + Listbox *listPtr; + + listPtr = (Listbox *) instanceData; + + gcValues.foreground = listPtr->fgColorPtr->pixel; + gcValues.font = Tk_FontId(listPtr->tkfont); + gcValues.graphics_exposures = False; + mask = GCForeground | GCFont | GCGraphicsExposures; + gc = Tk_GetGC(listPtr->tkwin, mask, &gcValues); + if (listPtr->textGC != None) { + Tk_FreeGC(listPtr->display, listPtr->textGC); + } + listPtr->textGC = gc; + + gcValues.foreground = listPtr->selFgColorPtr->pixel; + gcValues.font = Tk_FontId(listPtr->tkfont); + mask = GCForeground | GCFont; + gc = Tk_GetGC(listPtr->tkwin, mask, &gcValues); + if (listPtr->selTextGC != None) { + Tk_FreeGC(listPtr->display, listPtr->selTextGC); + } + listPtr->selTextGC = gc; + + /* + * Register the desired geometry for the window and arrange for + * the window to be redisplayed. + */ + + ListboxComputeGeometry(listPtr, 1, 1, 1); + listPtr->flags |= UPDATE_V_SCROLLBAR|UPDATE_H_SCROLLBAR; + EventuallyRedrawRange(listPtr, 0, listPtr->nElements-1); +} + +/* + *-------------------------------------------------------------- + * + * DisplayListbox -- + * + * This procedure redraws the contents of a listbox window. + * + * Results: + * None. + * + * Side effects: + * Information appears on the screen. + * + *-------------------------------------------------------------- + */ + +static void +DisplayListbox(clientData) + ClientData clientData; /* Information about window. */ +{ + register Listbox *listPtr = (Listbox *) clientData; + register Tk_Window tkwin = listPtr->tkwin; + GC gc; + int i, limit, x, y, width, prevSelected; + Tk_FontMetrics fm; + Tcl_Obj *curElement; + Tcl_HashEntry *entry; + char *stringRep; + int stringLen; + ItemAttr *attrs; + Tk_3DBorder selectedBg; + XGCValues gcValues; + unsigned long mask; + int left, right; /* Non-zero values here indicate + * that the left or right edge of + * the listbox is off-screen. */ + Pixmap pixmap; + + listPtr->flags &= ~REDRAW_PENDING; + + if (listPtr->flags & MAXWIDTH_IS_STALE) { + ListboxComputeGeometry(listPtr, 0, 1, 0); + listPtr->flags &= ~MAXWIDTH_IS_STALE; + listPtr->flags |= UPDATE_H_SCROLLBAR; + } + + if (listPtr->flags & UPDATE_V_SCROLLBAR) { + ListboxUpdateVScrollbar(listPtr); + } + if (listPtr->flags & UPDATE_H_SCROLLBAR) { + ListboxUpdateHScrollbar(listPtr); + } + listPtr->flags &= ~(REDRAW_PENDING|UPDATE_V_SCROLLBAR|UPDATE_H_SCROLLBAR); + if ((listPtr->tkwin == NULL) || !Tk_IsMapped(tkwin)) { + return; + } + + /* + * Redrawing is done in a temporary pixmap that is allocated + * here and freed at the end of the procedure. All drawing is + * done to the pixmap, and the pixmap is copied to the screen + * at the end of the procedure. This provides the smoothest + * possible visual effects (no flashing on the screen). + */ + + pixmap = Tk_GetPixmap(listPtr->display, Tk_WindowId(tkwin), + Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin)); + Tk_Fill3DRectangle(tkwin, pixmap, listPtr->normalBorder, 0, 0, + Tk_Width(tkwin), Tk_Height(tkwin), 0, TK_RELIEF_FLAT); + + /* Display each item in the listbox */ + limit = listPtr->topIndex + listPtr->fullLines + listPtr->partialLine - 1; + if (limit >= listPtr->nElements) { + limit = listPtr->nElements-1; + } + left = right = 0; + if (listPtr->xOffset > 0) { + left = listPtr->selBorderWidth+1; + } + if ((listPtr->maxWidth - listPtr->xOffset) > (Tk_Width(listPtr->tkwin) + - 2*(listPtr->inset + listPtr->selBorderWidth))) { + right = listPtr->selBorderWidth+1; + } + prevSelected = 0; + + for (i = listPtr->topIndex; i <= limit; i++) { + x = listPtr->inset; + y = ((i - listPtr->topIndex) * listPtr->lineHeight) + + listPtr->inset; + gc = listPtr->textGC; + /* + * Lookup this item in the item attributes table, to see if it has + * special foreground/background colors + */ + entry = Tcl_FindHashEntry(listPtr->itemAttrTable, (char *)i); + + /* If the item is selected, it is drawn differently */ + if (Tcl_FindHashEntry(listPtr->selection, (char *)i) != NULL) { + gc = listPtr->selTextGC; + width = Tk_Width(tkwin) - 2*listPtr->inset; + selectedBg = listPtr->selBorder; + + /* If there is attribute information for this item, + * adjust the drawing accordingly */ + if (entry != NULL) { + attrs = (ItemAttr *)Tcl_GetHashValue(entry); + /* The default GC has the settings from the widget at large */ + gcValues.foreground = listPtr->selFgColorPtr->pixel; + gcValues.font = Tk_FontId(listPtr->tkfont); + gcValues.graphics_exposures = False; + mask = GCForeground | GCFont | GCGraphicsExposures; + + if (attrs->selBorder != NULL) { + selectedBg = attrs->selBorder; + } + + if (attrs->selFgColor != NULL) { + gcValues.foreground = attrs->selFgColor->pixel; + gc = Tk_GetGC(listPtr->tkwin, mask, &gcValues); + } + } + + Tk_Fill3DRectangle(tkwin, pixmap, selectedBg, x, y, + width, listPtr->lineHeight, 0, TK_RELIEF_FLAT); + + /* + * Draw beveled edges around the selection, if there are visible + * edges next to this element. Special considerations: + * 1. The left and right bevels may not be visible if horizontal + * scrolling is enabled (the "left" and "right" variables + * are zero to indicate that the corresponding bevel is + * visible). + * 2. Top and bottom bevels are only drawn if this is the + * first or last seleted item. + * 3. If the left or right bevel isn't visible, then the "left" + * and "right" variables, computed above, have non-zero values + * that extend the top and bottom bevels so that the mitered + * corners are off-screen. + */ + + /* Draw left bevel */ + if (left == 0) { + Tk_3DVerticalBevel(tkwin, pixmap, selectedBg, + x, y, listPtr->selBorderWidth, listPtr->lineHeight, + 1, TK_RELIEF_RAISED); + } + /* Draw right bevel */ + if (right == 0) { + Tk_3DVerticalBevel(tkwin, pixmap, selectedBg, + x + width - listPtr->selBorderWidth, y, + listPtr->selBorderWidth, listPtr->lineHeight, + 0, TK_RELIEF_RAISED); + } + /* Draw top bevel */ + if (!prevSelected) { + Tk_3DHorizontalBevel(tkwin, pixmap, selectedBg, + x-left, y, width+left+right, listPtr->selBorderWidth, + 1, 1, 1, TK_RELIEF_RAISED); + } + /* Draw bottom bevel */ + if (i + 1 == listPtr->nElements || + Tcl_FindHashEntry(listPtr->selection, + (char *)(i + 1)) == NULL ) { + Tk_3DHorizontalBevel(tkwin, pixmap, selectedBg, x-left, + y + listPtr->lineHeight - listPtr->selBorderWidth, + width+left+right, listPtr->selBorderWidth, 0, 0, 0, + TK_RELIEF_RAISED); + } + prevSelected = 1; + } else { + /* If there is an item attributes record for this item, + * draw the background box and set the foreground color + * accordingly */ + if (entry != NULL) { + attrs = (ItemAttr *)Tcl_GetHashValue(entry); + gcValues.foreground = listPtr->fgColorPtr->pixel; + gcValues.font = Tk_FontId(listPtr->tkfont); + gcValues.graphics_exposures = False; + mask = GCForeground | GCFont | GCGraphicsExposures; + if (attrs->border != NULL) { + width = Tk_Width(tkwin) - 2*listPtr->inset; + Tk_Fill3DRectangle(tkwin, pixmap, attrs->border, x, y, + width, listPtr->lineHeight, 0, TK_RELIEF_FLAT); + } + if (attrs->fgColor != NULL) { + gcValues.foreground = attrs->fgColor->pixel; + gc = Tk_GetGC(listPtr->tkwin, mask, &gcValues); + } + } + prevSelected = 0; + } + + /* Draw the actual text of this item */ + Tk_GetFontMetrics(listPtr->tkfont, &fm); + y += fm.ascent + listPtr->selBorderWidth; + x = listPtr->inset + listPtr->selBorderWidth - listPtr->xOffset; + Tcl_ListObjIndex(listPtr->interp, listPtr->listObj, i, &curElement); + stringRep = Tcl_GetStringFromObj(curElement, &stringLen); + Tk_DrawChars(listPtr->display, pixmap, gc, listPtr->tkfont, + stringRep, stringLen, x, y); + + /* If this is the active element, underline it. */ + if ((i == listPtr->active) && (listPtr->flags & GOT_FOCUS)) { + Tk_UnderlineChars(listPtr->display, pixmap, gc, listPtr->tkfont, + stringRep, x, y, 0, stringLen); + } + } + + /* + * Redraw the border for the listbox to make sure that it's on top + * of any of the text of the listbox entries. + */ + + Tk_Draw3DRectangle(tkwin, pixmap, listPtr->normalBorder, + listPtr->highlightWidth, listPtr->highlightWidth, + Tk_Width(tkwin) - 2*listPtr->highlightWidth, + Tk_Height(tkwin) - 2*listPtr->highlightWidth, + listPtr->borderWidth, listPtr->relief); + if (listPtr->highlightWidth > 0) { + GC fgGC, bgGC; + + bgGC = Tk_GCForColor(listPtr->highlightBgColorPtr, pixmap); + if (listPtr->flags & GOT_FOCUS) { + fgGC = Tk_GCForColor(listPtr->highlightColorPtr, pixmap); + TkpDrawHighlightBorder(tkwin, fgGC, bgGC, + listPtr->highlightWidth, pixmap); + } else { + TkpDrawHighlightBorder(tkwin, bgGC, bgGC, + listPtr->highlightWidth, pixmap); + } + } + XCopyArea(listPtr->display, pixmap, Tk_WindowId(tkwin), + listPtr->textGC, 0, 0, (unsigned) Tk_Width(tkwin), + (unsigned) Tk_Height(tkwin), 0, 0); + Tk_FreePixmap(listPtr->display, pixmap); +} + +/* + *---------------------------------------------------------------------- + * + * ListboxComputeGeometry -- + * + * This procedure is invoked to recompute geometry information + * such as the sizes of the elements and the overall dimensions + * desired for the listbox. + * + * Results: + * None. + * + * Side effects: + * Geometry information is updated and a new requested size is + * registered for the widget. Internal border and gridding + * information is also set. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxComputeGeometry(listPtr, fontChanged, maxIsStale, updateGrid) + Listbox *listPtr; /* Listbox whose geometry is to be + * recomputed. */ + int fontChanged; /* Non-zero means the font may have changed + * so per-element width information also + * has to be computed. */ + int maxIsStale; /* Non-zero means the "maxWidth" field may + * no longer be up-to-date and must + * be recomputed. If fontChanged is 1 then + * this must be 1. */ + int updateGrid; /* Non-zero means call Tk_SetGrid or + * Tk_UnsetGrid to update gridding for + * the window. */ +{ + int width, height, pixelWidth, pixelHeight; + Tk_FontMetrics fm; + Tcl_Obj *element; + int textLength; + char *text; + int i, result; + + if (fontChanged || maxIsStale) { + listPtr->xScrollUnit = Tk_TextWidth(listPtr->tkfont, "0", 1); + if (listPtr->xScrollUnit == 0) { + listPtr->xScrollUnit = 1; + } + listPtr->maxWidth = 0; + for (i = 0; i < listPtr->nElements; i++) { + /* Compute the pixel width of the current element */ + result = Tcl_ListObjIndex(listPtr->interp, listPtr->listObj, i, + &element); + if (result != TCL_OK) { + continue; + } + text = Tcl_GetStringFromObj(element, &textLength); + Tk_GetFontMetrics(listPtr->tkfont, &fm); + pixelWidth = Tk_TextWidth(listPtr->tkfont, text, textLength); + if (pixelWidth > listPtr->maxWidth) { + listPtr->maxWidth = pixelWidth; + } + } + } + + Tk_GetFontMetrics(listPtr->tkfont, &fm); + listPtr->lineHeight = fm.linespace + 1 + 2*listPtr->selBorderWidth; + width = listPtr->width; + if (width <= 0) { + width = (listPtr->maxWidth + listPtr->xScrollUnit - 1) + /listPtr->xScrollUnit; + if (width < 1) { + width = 1; + } + } + pixelWidth = width*listPtr->xScrollUnit + 2*listPtr->inset + + 2*listPtr->selBorderWidth; + height = listPtr->height; + if (listPtr->height <= 0) { + height = listPtr->nElements; + if (height < 1) { + height = 1; + } + } + pixelHeight = height*listPtr->lineHeight + 2*listPtr->inset; + Tk_GeometryRequest(listPtr->tkwin, pixelWidth, pixelHeight); + Tk_SetInternalBorder(listPtr->tkwin, listPtr->inset); + if (updateGrid) { + if (listPtr->setGrid) { + Tk_SetGrid(listPtr->tkwin, width, height, listPtr->xScrollUnit, + listPtr->lineHeight); + } else { + Tk_UnsetGrid(listPtr->tkwin); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ListboxInsertSubCmd -- + * + * This procedure is invoked to handle the listbox "insert" + * subcommand. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * New elements are added to the listbox pointed to by listPtr; + * a refresh callback is registered for the listbox. + * + *---------------------------------------------------------------------- + */ + +static int +ListboxInsertSubCmd(listPtr, index, objc, objv) + register Listbox *listPtr; /* Listbox that is to get the new + * elements. */ + int index; /* Add the new elements before this + * element. */ + int objc; /* Number of new elements to add. */ + Tcl_Obj *CONST objv[]; /* New elements (one per entry). */ +{ + int i, oldMaxWidth; + Tcl_Obj *newListObj; + int pixelWidth; + int result; + char *stringRep; + int length; + + oldMaxWidth = listPtr->maxWidth; + for (i = 0; i < objc; i++) { + /* + * Check if any of the new elements are wider than the current widest; + * if so, update our notion of "widest." + */ + stringRep = Tcl_GetStringFromObj(objv[i], &length); + pixelWidth = Tk_TextWidth(listPtr->tkfont, stringRep, length); + if (pixelWidth > listPtr->maxWidth) { + listPtr->maxWidth = pixelWidth; + } + } + + /* Adjust selection and attribute information for every index after + * the first index */ + MigrateHashEntries(listPtr->selection, index, listPtr->nElements-1, objc); + MigrateHashEntries(listPtr->itemAttrTable, index, listPtr->nElements-1, + objc); + + /* If the object is shared, duplicate it before writing to it */ + if (Tcl_IsShared(listPtr->listObj)) { + newListObj = Tcl_DuplicateObj(listPtr->listObj); + } else { + newListObj = listPtr->listObj; + } + result = + Tcl_ListObjReplace(listPtr->interp, newListObj, index, 0, objc, objv); + if (result != TCL_OK) { + return result; + } + + Tcl_IncrRefCount(newListObj); + /* Clean up the old reference */ + Tcl_DecrRefCount(listPtr->listObj); + + /* Set the internal pointer to the new obj */ + listPtr->listObj = newListObj; + + /* If there is a listvar, make sure it points at the new object */ + if (listPtr->listVarName != NULL) { + if (Tcl_SetVar2Ex(listPtr->interp, listPtr->listVarName, + (char *)NULL, newListObj, TCL_GLOBAL_ONLY) == NULL) { + Tcl_DecrRefCount(newListObj); + return TCL_ERROR; + } + } + + /* Get the new list length */ + Tcl_ListObjLength(listPtr->interp, listPtr->listObj, &listPtr->nElements); + + /* + * Update the "special" indices (anchor, topIndex, active) to account + * for the renumbering that just occurred. Then arrange for the new + * information to be displayed. + */ + + if (index <= listPtr->selectAnchor) { + listPtr->selectAnchor += objc; + } + if (index < listPtr->topIndex) { + listPtr->topIndex += objc; + } + if (index <= listPtr->active) { + listPtr->active += objc; + if ((listPtr->active >= listPtr->nElements) && + (listPtr->nElements > 0)) { + listPtr->active = listPtr->nElements-1; + } + } + listPtr->flags |= UPDATE_V_SCROLLBAR; + if (listPtr->maxWidth != oldMaxWidth) { + listPtr->flags |= UPDATE_H_SCROLLBAR; + } + ListboxComputeGeometry(listPtr, 0, 0, 0); + EventuallyRedrawRange(listPtr, index, listPtr->nElements-1); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ListboxDeleteSubCmd -- + * + * Process a listbox "delete" subcommand by removing one or more + * elements from a listbox widget. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * The listbox will be modified and (eventually) redisplayed. + * + *---------------------------------------------------------------------- + */ + +static int +ListboxDeleteSubCmd(listPtr, first, last) + register Listbox *listPtr; /* Listbox widget to modify. */ + int first; /* Index of first element to delete. */ + int last; /* Index of last element to delete. */ +{ + int count, i, widthChanged; + Tcl_Obj *newListObj; + Tcl_Obj *element; + int length; + char *stringRep; + int result; + int pixelWidth; + Tcl_HashEntry *entry; + + /* + * Adjust the range to fit within the existing elements of the + * listbox, and make sure there's something to delete. + */ + + if (first < 0) { + first = 0; + } + if (last >= listPtr->nElements) { + last = listPtr->nElements-1; + } + count = last + 1 - first; + if (count <= 0) { + return TCL_OK; + } + + /* + * Foreach deleted index we must: + * a) remove selection information + * b) check the width of the element; if it is equal to the max, set + * widthChanged to 1, because it may be the only element with that + * width + */ + widthChanged = 0; + for (i = first; i <= last; i++) { + /* Remove selection information */ + entry = Tcl_FindHashEntry(listPtr->selection, (char *)i); + if (entry != NULL) { + listPtr->numSelected--; + Tcl_DeleteHashEntry(entry); + } + + entry = Tcl_FindHashEntry(listPtr->itemAttrTable, (char *)i); + if (entry != NULL) { + Tcl_DeleteHashEntry(entry); + } + + /* Check width of the element. We only have to check if widthChanged + * has not already been set to 1, because we only need one maxWidth + * element to disappear for us to have to recompute the width + */ + if (widthChanged == 0) { + Tcl_ListObjIndex(listPtr->interp, listPtr->listObj, i, &element); + stringRep = Tcl_GetStringFromObj(element, &length); + pixelWidth = Tk_TextWidth(listPtr->tkfont, stringRep, length); + if (pixelWidth == listPtr->maxWidth) { + widthChanged = 1; + } + } + } + + /* Adjust selection and attribute info for indices after lastIndex */ + MigrateHashEntries(listPtr->selection, last+1, + listPtr->nElements-1, count*-1); + MigrateHashEntries(listPtr->itemAttrTable, last+1, + listPtr->nElements-1, count*-1); + + /* Delete the requested elements */ + if (Tcl_IsShared(listPtr->listObj)) { + newListObj = Tcl_DuplicateObj(listPtr->listObj); + } else { + newListObj = listPtr->listObj; + } + result = Tcl_ListObjReplace(listPtr->interp, + newListObj, first, count, 0, NULL); + if (result != TCL_OK) { + return result; + } + + Tcl_IncrRefCount(newListObj); + /* Clean up the old reference */ + Tcl_DecrRefCount(listPtr->listObj); + + /* Set the internal pointer to the new obj */ + listPtr->listObj = newListObj; + + /* Get the new list length */ + Tcl_ListObjLength(listPtr->interp, listPtr->listObj, &listPtr->nElements); + + /* If there is a listvar, make sure it points at the new object */ + if (listPtr->listVarName != NULL) { + if (Tcl_SetVar2Ex(listPtr->interp, listPtr->listVarName, + (char *)NULL, newListObj, TCL_GLOBAL_ONLY) == NULL) { + Tcl_DecrRefCount(newListObj); + return TCL_ERROR; + } + } + + /* + * Update the selection and viewing information to reflect the change + * in the element numbering, and redisplay to slide information up over + * the elements that were deleted. + */ + + if (first <= listPtr->selectAnchor) { + listPtr->selectAnchor -= count; + if (listPtr->selectAnchor < first) { + listPtr->selectAnchor = first; + } + } + if (first <= listPtr->topIndex) { + listPtr->topIndex -= count; + if (listPtr->topIndex < first) { + listPtr->topIndex = first; + } + } + if (listPtr->topIndex > (listPtr->nElements - listPtr->fullLines)) { + listPtr->topIndex = listPtr->nElements - listPtr->fullLines; + if (listPtr->topIndex < 0) { + listPtr->topIndex = 0; + } + } + if (listPtr->active > last) { + listPtr->active -= count; + } else if (listPtr->active >= first) { + listPtr->active = first; + if ((listPtr->active >= listPtr->nElements) && + (listPtr->nElements > 0)) { + listPtr->active = listPtr->nElements-1; + } + } + listPtr->flags |= UPDATE_V_SCROLLBAR; + ListboxComputeGeometry(listPtr, 0, widthChanged, 0); + if (widthChanged) { + listPtr->flags |= UPDATE_H_SCROLLBAR; + } + EventuallyRedrawRange(listPtr, first, listPtr->nElements-1); + return TCL_OK; +} + +/* + *-------------------------------------------------------------- + * + * ListboxEventProc -- + * + * This procedure is invoked by the Tk dispatcher for various + * events on listboxes. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get + * cleaned up. When it gets exposed, it is redisplayed. + * + *-------------------------------------------------------------- + */ + +static void +ListboxEventProc(clientData, eventPtr) + ClientData clientData; /* Information about window. */ + XEvent *eventPtr; /* Information about event. */ +{ + Listbox *listPtr = (Listbox *) clientData; + + if (eventPtr->type == Expose) { + EventuallyRedrawRange(listPtr, + NearestListboxElement(listPtr, eventPtr->xexpose.y), + NearestListboxElement(listPtr, eventPtr->xexpose.y + + eventPtr->xexpose.height)); + } else if (eventPtr->type == DestroyNotify) { + DestroyListbox((char *) clientData); + } else if (eventPtr->type == ConfigureNotify) { + int vertSpace; + + vertSpace = Tk_Height(listPtr->tkwin) - 2*listPtr->inset; + listPtr->fullLines = vertSpace / listPtr->lineHeight; + if ((listPtr->fullLines*listPtr->lineHeight) < vertSpace) { + listPtr->partialLine = 1; + } else { + listPtr->partialLine = 0; + } + listPtr->flags |= UPDATE_V_SCROLLBAR|UPDATE_H_SCROLLBAR; + ChangeListboxView(listPtr, listPtr->topIndex); + ChangeListboxOffset(listPtr, listPtr->xOffset); + + /* + * Redraw the whole listbox. It's hard to tell what needs + * to be redrawn (e.g. if the listbox has shrunk then we + * may only need to redraw the borders), so just redraw + * everything for safety. + */ + + EventuallyRedrawRange(listPtr, 0, listPtr->nElements-1); + } else if (eventPtr->type == FocusIn) { + if (eventPtr->xfocus.detail != NotifyInferior) { + listPtr->flags |= GOT_FOCUS; + EventuallyRedrawRange(listPtr, 0, listPtr->nElements-1); + } + } else if (eventPtr->type == FocusOut) { + if (eventPtr->xfocus.detail != NotifyInferior) { + listPtr->flags &= ~GOT_FOCUS; + EventuallyRedrawRange(listPtr, 0, listPtr->nElements-1); + } + } +} + +/* + *---------------------------------------------------------------------- + * + * ListboxCmdDeletedProc -- + * + * This procedure is invoked when a widget command is deleted. If + * the widget isn't already in the process of being destroyed, + * this command destroys it. + * + * Results: + * None. + * + * Side effects: + * The widget is destroyed. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxCmdDeletedProc(clientData) + ClientData clientData; /* Pointer to widget record for widget. */ +{ + Listbox *listPtr = (Listbox *) clientData; + + /* + * This procedure could be invoked either because the window was + * destroyed and the command was then deleted (in which case tkwin + * is NULL) or because the command was deleted, and then this procedure + * destroys the widget. + */ + + if (!(listPtr->flags & LISTBOX_DELETED)) { + Tk_DestroyWindow(listPtr->tkwin); + } +} + +/* + *-------------------------------------------------------------- + * + * GetListboxIndex -- + * + * Parse an index into a listbox and return either its value + * or an error. + * + * Results: + * A standard Tcl result. If all went well, then *indexPtr is + * filled in with the index (into listPtr) corresponding to + * string. Otherwise an error message is left in the interp's result. + * + * Side effects: + * None. + * + *-------------------------------------------------------------- + */ + +static int +GetListboxIndex(interp, listPtr, indexObj, endIsSize, indexPtr) + Tcl_Interp *interp; /* For error messages. */ + Listbox *listPtr; /* Listbox for which the index is being + * specified. */ + Tcl_Obj *indexObj; /* Specifies an element in the listbox. */ + int endIsSize; /* If 1, "end" refers to the number of + * entries in the listbox. If 0, "end" + * refers to 1 less than the number of + * entries. */ + int *indexPtr; /* Where to store converted index. */ +{ + int result; + int index; + char *stringRep; + + /* First see if the index is one of the named indices */ + result = Tcl_GetIndexFromObj(NULL, indexObj, indexNames, "", 0, &index); + if (result == TCL_OK) { + switch (index) { + case INDEX_ACTIVE: { + /* "active" index */ + *indexPtr = listPtr->active; + break; + } + + case INDEX_ANCHOR: { + /* "anchor" index */ + *indexPtr = listPtr->selectAnchor; + break; + } + + case INDEX_END: { + /* "end" index */ + if (endIsSize) { + *indexPtr = listPtr->nElements; + } else { + *indexPtr = listPtr->nElements - 1; + } + break; + } + } + return TCL_OK; + } + + /* The index didn't match any of the named indices; maybe it's an @x,y */ + stringRep = Tcl_GetString(indexObj); + if (stringRep[0] == '@') { + /* @x,y index */ + int y; + char *start, *end; + start = stringRep + 1; + strtol(start, &end, 0); + if ((start == end) || (*end != ',')) { + Tcl_AppendResult(interp, "bad listbox index \"", stringRep, + "\": must be active, anchor, end, @x,y, or a number", + (char *)NULL); + return TCL_ERROR; + } + start = end+1; + y = strtol(start, &end, 0); + if ((start == end) || (*end != '\0')) { + Tcl_AppendResult(interp, "bad listbox index \"", stringRep, + "\": must be active, anchor, end, @x,y, or a number", + (char *)NULL); + return TCL_ERROR; + } + *indexPtr = NearestListboxElement(listPtr, y); + return TCL_OK; + } + + /* Maybe the index is just an integer */ + if (Tcl_GetIntFromObj(interp, indexObj, indexPtr) == TCL_OK) { + return TCL_OK; + } + + /* Everything failed, nothing matched. Throw up an error message */ + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad listbox index \"", + Tcl_GetString(indexObj), "\": must be active, anchor, ", + "end, @x,y, or a number", (char *) NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * ChangeListboxView -- + * + * Change the view on a listbox widget so that a given element + * is displayed at the top. + * + * Results: + * None. + * + * Side effects: + * What's displayed on the screen is changed. If there is a + * scrollbar associated with this widget, then the scrollbar + * is instructed to change its display too. + * + *---------------------------------------------------------------------- + */ + +static void +ChangeListboxView(listPtr, index) + register Listbox *listPtr; /* Information about widget. */ + int index; /* Index of element in listPtr + * that should now appear at the + * top of the listbox. */ +{ + if (index >= (listPtr->nElements - listPtr->fullLines)) { + index = listPtr->nElements - listPtr->fullLines; + } + if (index < 0) { + index = 0; + } + if (listPtr->topIndex != index) { + listPtr->topIndex = index; + EventuallyRedrawRange(listPtr, 0, listPtr->nElements-1); + listPtr->flags |= UPDATE_V_SCROLLBAR; + } +} + +/* + *---------------------------------------------------------------------- + * + * ChangListboxOffset -- + * + * Change the horizontal offset for a listbox. + * + * Results: + * None. + * + * Side effects: + * The listbox may be redrawn to reflect its new horizontal + * offset. + * + *---------------------------------------------------------------------- + */ + +static void +ChangeListboxOffset(listPtr, offset) + register Listbox *listPtr; /* Information about widget. */ + int offset; /* Desired new "xOffset" for + * listbox. */ +{ + int maxOffset; + + /* + * Make sure that the new offset is within the allowable range, and + * round it off to an even multiple of xScrollUnit. + */ + + maxOffset = listPtr->maxWidth - (Tk_Width(listPtr->tkwin) - + 2*listPtr->inset - 2*listPtr->selBorderWidth) + + listPtr->xScrollUnit - 1; + if (offset > maxOffset) { + offset = maxOffset; + } + if (offset < 0) { + offset = 0; + } + offset -= offset % listPtr->xScrollUnit; + if (offset != listPtr->xOffset) { + listPtr->xOffset = offset; + listPtr->flags |= UPDATE_H_SCROLLBAR; + EventuallyRedrawRange(listPtr, 0, listPtr->nElements-1); + } +} + +/* + *---------------------------------------------------------------------- + * + * ListboxScanTo -- + * + * Given a point (presumably of the curent mouse location) + * drag the view in the window to implement the scan operation. + * + * Results: + * None. + * + * Side effects: + * The view in the window may change. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxScanTo(listPtr, x, y) + register Listbox *listPtr; /* Information about widget. */ + int x; /* X-coordinate to use for scan + * operation. */ + int y; /* Y-coordinate to use for scan + * operation. */ +{ + int newTopIndex, newOffset, maxIndex, maxOffset; + + maxIndex = listPtr->nElements - listPtr->fullLines; + maxOffset = listPtr->maxWidth + (listPtr->xScrollUnit - 1) + - (Tk_Width(listPtr->tkwin) - 2*listPtr->inset + - 2*listPtr->selBorderWidth - listPtr->xScrollUnit); + + /* + * Compute new top line for screen by amplifying the difference + * between the current position and the place where the scan + * started (the "mark" position). If we run off the top or bottom + * of the list, then reset the mark point so that the current + * position continues to correspond to the edge of the window. + * This means that the picture will start dragging as soon as the + * mouse reverses direction (without this reset, might have to slide + * mouse a long ways back before the picture starts moving again). + */ + + newTopIndex = listPtr->scanMarkYIndex + - (10*(y - listPtr->scanMarkY))/listPtr->lineHeight; + if (newTopIndex > maxIndex) { + newTopIndex = listPtr->scanMarkYIndex = maxIndex; + listPtr->scanMarkY = y; + } else if (newTopIndex < 0) { + newTopIndex = listPtr->scanMarkYIndex = 0; + listPtr->scanMarkY = y; + } + ChangeListboxView(listPtr, newTopIndex); + + /* + * Compute new left edge for display in a similar fashion by amplifying + * the difference between the current position and the place where the + * scan started. + */ + + newOffset = listPtr->scanMarkXOffset - (10*(x - listPtr->scanMarkX)); + if (newOffset > maxOffset) { + newOffset = listPtr->scanMarkXOffset = maxOffset; + listPtr->scanMarkX = x; + } else if (newOffset < 0) { + newOffset = listPtr->scanMarkXOffset = 0; + listPtr->scanMarkX = x; + } + ChangeListboxOffset(listPtr, newOffset); +} + +/* + *---------------------------------------------------------------------- + * + * NearestListboxElement -- + * + * Given a y-coordinate inside a listbox, compute the index of + * the element under that y-coordinate (or closest to that + * y-coordinate). + * + * Results: + * The return value is an index of an element of listPtr. If + * listPtr has no elements, then 0 is always returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +NearestListboxElement(listPtr, y) + register Listbox *listPtr; /* Information about widget. */ + int y; /* Y-coordinate in listPtr's window. */ +{ + int index; + + index = (y - listPtr->inset)/listPtr->lineHeight; + if (index >= (listPtr->fullLines + listPtr->partialLine)) { + index = listPtr->fullLines + listPtr->partialLine - 1; + } + if (index < 0) { + index = 0; + } + index += listPtr->topIndex; + if (index >= listPtr->nElements) { + index = listPtr->nElements-1; + } + return index; +} + +/* + *---------------------------------------------------------------------- + * + * ListboxSelect -- + * + * Select or deselect one or more elements in a listbox.. + * + * Results: + * Standard Tcl result. + * + * Side effects: + * All of the elements in the range between first and last are + * marked as either selected or deselected, depending on the + * "select" argument. Any items whose state changes are redisplayed. + * The selection is claimed from X when the number of selected + * elements changes from zero to non-zero. + * + *---------------------------------------------------------------------- + */ + +static int +ListboxSelect(listPtr, first, last, select) + register Listbox *listPtr; /* Information about widget. */ + int first; /* Index of first element to + * select or deselect. */ + int last; /* Index of last element to + * select or deselect. */ + int select; /* 1 means select items, 0 means + * deselect them. */ +{ + int i, firstRedisplay, increment, oldCount; + Tcl_HashEntry *entry; + int new; + + if (last < first) { + i = first; + first = last; + last = i; + } + if ((last < 0) || (first >= listPtr->nElements)) { + return TCL_OK; + } + if (first < 0) { + first = 0; + } + if (last >= listPtr->nElements) { + last = listPtr->nElements - 1; + } + oldCount = listPtr->numSelected; + firstRedisplay = -1; + increment = select ? 1 : -1; + + /* + * For each index in the range, find it in our selection hash table. + * If it's not there but should be, add it. If it's there but shouldn't + * be, remove it. + */ + for (i = first; i <= last; i++) { + entry = Tcl_FindHashEntry(listPtr->selection, (char *)i); + if (entry != NULL) { + if (!select) { + Tcl_DeleteHashEntry(entry); + listPtr->numSelected--; + if (firstRedisplay < 0) { + firstRedisplay = i; + } + } + } else { + if (select) { + entry = Tcl_CreateHashEntry(listPtr->selection, + (char *)i, &new); + Tcl_SetHashValue(entry, (ClientData) NULL); + listPtr->numSelected++; + if (firstRedisplay < 0) { + firstRedisplay = i; + } + } + } + } + + if (firstRedisplay >= 0) { + EventuallyRedrawRange(listPtr, first, last); + } + if ((oldCount == 0) && (listPtr->numSelected > 0) + && (listPtr->exportSelection)) { + Tk_OwnSelection(listPtr->tkwin, XA_PRIMARY, ListboxLostSelection, + (ClientData) listPtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ListboxFetchSelection -- + * + * This procedure is called back by Tk when the selection is + * requested by someone. It returns part or all of the selection + * in a buffer provided by the caller. + * + * Results: + * The return value is the number of non-NULL bytes stored + * at buffer. Buffer is filled (or partially filled) with a + * NULL-terminated string containing part or all of the selection, + * as given by offset and maxBytes. The selection is returned + * as a Tcl list with one list element for each element in the + * listbox. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +ListboxFetchSelection(clientData, offset, buffer, maxBytes) + ClientData clientData; /* Information about listbox widget. */ + int offset; /* Offset within selection of first + * byte to be returned. */ + char *buffer; /* Location in which to place + * selection. */ + int maxBytes; /* Maximum number of bytes to place + * at buffer, not including terminating + * NULL character. */ +{ + register Listbox *listPtr = (Listbox *) clientData; + Tcl_DString selection; + int length, count, needNewline; + Tcl_Obj *curElement; + char *stringRep; + int stringLen; + Tcl_HashEntry *entry; + int i; + + if (!listPtr->exportSelection) { + return -1; + } + + /* + * Use a dynamic string to accumulate the contents of the selection. + */ + + needNewline = 0; + Tcl_DStringInit(&selection); + for (i = 0; i < listPtr->nElements; i++) { + entry = Tcl_FindHashEntry(listPtr->selection, (char *)i); + if (entry != NULL) { + if (needNewline) { + Tcl_DStringAppend(&selection, "\n", 1); + } + Tcl_ListObjIndex(listPtr->interp, listPtr->listObj, i, + &curElement); + stringRep = Tcl_GetStringFromObj(curElement, &stringLen); + Tcl_DStringAppend(&selection, stringRep, stringLen); + needNewline = 1; + } + } + + length = Tcl_DStringLength(&selection); + if (length == 0) { + return -1; + } + + /* + * Copy the requested portion of the selection to the buffer. + */ + + count = length - offset; + if (count <= 0) { + count = 0; + } else { + if (count > maxBytes) { + count = maxBytes; + } + memcpy((VOID *) buffer, + (VOID *) (Tcl_DStringValue(&selection) + offset), + (size_t) count); + } + buffer[count] = '\0'; + Tcl_DStringFree(&selection); + return count; +} + +/* + *---------------------------------------------------------------------- + * + * ListboxLostSelection -- + * + * This procedure is called back by Tk when the selection is + * grabbed away from a listbox widget. + * + * Results: + * None. + * + * Side effects: + * The existing selection is unhighlighted, and the window is + * marked as not containing a selection. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxLostSelection(clientData) + ClientData clientData; /* Information about listbox widget. */ +{ + register Listbox *listPtr = (Listbox *) clientData; + + if ((listPtr->exportSelection) && (listPtr->nElements > 0)) { + ListboxSelect(listPtr, 0, listPtr->nElements-1, 0); + } +} + +/* + *---------------------------------------------------------------------- + * + * EventuallyRedrawRange -- + * + * Ensure that a given range of elements is eventually redrawn on + * the display (if those elements in fact appear on the display). + * + * Results: + * None. + * + * Side effects: + * Information gets redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +EventuallyRedrawRange(listPtr, first, last) + register Listbox *listPtr; /* Information about widget. */ + int first; /* Index of first element in list + * that needs to be redrawn. */ + int last; /* Index of last element in list + * that needs to be redrawn. May + * be less than first; + * these just bracket a range. */ +{ + /* We don't have to register a redraw callback if one is already pending, + * or if the window doesn't exist, or if the window isn't mapped */ + if ((listPtr->flags & REDRAW_PENDING) + || (listPtr->tkwin == NULL) + || !Tk_IsMapped(listPtr->tkwin)) { + return; + } + listPtr->flags |= REDRAW_PENDING; + Tcl_DoWhenIdle(DisplayListbox, (ClientData) listPtr); +} + +/* + *---------------------------------------------------------------------- + * + * ListboxUpdateVScrollbar -- + * + * This procedure is invoked whenever information has changed in + * a listbox in a way that would invalidate a vertical scrollbar + * display. If there is an associated scrollbar, then this command + * updates it by invoking a Tcl command. + * + * Results: + * None. + * + * Side effects: + * A Tcl command is invoked, and an additional command may be + * invoked to process errors in the command. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxUpdateVScrollbar(listPtr) + register Listbox *listPtr; /* Information about widget. */ +{ + char string[TCL_DOUBLE_SPACE * 2]; + double first, last; + int result; + Tcl_Interp *interp; + + if (listPtr->yScrollCmd == NULL) { + return; + } + if (listPtr->nElements == 0) { + first = 0.0; + last = 1.0; + } else { + first = listPtr->topIndex/((double) listPtr->nElements); + last = (listPtr->topIndex+listPtr->fullLines) + /((double) listPtr->nElements); + if (last > 1.0) { + last = 1.0; + } + } + sprintf(string, " %g %g", first, last); + + /* + * We must hold onto the interpreter from the listPtr because the data + * at listPtr might be freed as a result of the Tcl_VarEval. + */ + + interp = listPtr->interp; + Tcl_Preserve((ClientData) interp); + result = Tcl_VarEval(interp, listPtr->yScrollCmd, string, + (char *) NULL); + if (result != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (vertical scrolling command executed by listbox)"); + Tcl_BackgroundError(interp); + } + Tcl_Release((ClientData) interp); +} + +/* + *---------------------------------------------------------------------- + * + * ListboxUpdateHScrollbar -- + * + * This procedure is invoked whenever information has changed in + * a listbox in a way that would invalidate a horizontal scrollbar + * display. If there is an associated horizontal scrollbar, then + * this command updates it by invoking a Tcl command. + * + * Results: + * None. + * + * Side effects: + * A Tcl command is invoked, and an additional command may be + * invoked to process errors in the command. + * + *---------------------------------------------------------------------- + */ + +static void +ListboxUpdateHScrollbar(listPtr) + register Listbox *listPtr; /* Information about widget. */ +{ + char string[TCL_DOUBLE_SPACE * 2]; + int result, windowWidth; + double first, last; + Tcl_Interp *interp; + + if (listPtr->xScrollCmd == NULL) { + return; + } + windowWidth = Tk_Width(listPtr->tkwin) - 2*(listPtr->inset + + listPtr->selBorderWidth); + if (listPtr->maxWidth == 0) { + first = 0; + last = 1.0; + } else { + first = listPtr->xOffset/((double) listPtr->maxWidth); + last = (listPtr->xOffset + windowWidth) + /((double) listPtr->maxWidth); + if (last > 1.0) { + last = 1.0; + } + } + sprintf(string, " %g %g", first, last); + + /* + * We must hold onto the interpreter because the data referred to at + * listPtr might be freed as a result of the call to Tcl_VarEval. + */ + + interp = listPtr->interp; + Tcl_Preserve((ClientData) interp); + result = Tcl_VarEval(interp, listPtr->xScrollCmd, string, + (char *) NULL); + if (result != TCL_OK) { + Tcl_AddErrorInfo(interp, + "\n (horizontal scrolling command executed by listbox)"); + Tcl_BackgroundError(interp); + } + Tcl_Release((ClientData) interp); +} + +/* + *---------------------------------------------------------------------- + * + * ListboxListVarProc -- + * + * Called whenever the trace on the listbox list var fires. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static char * +ListboxListVarProc(clientData, interp, name1, name2, flags) + ClientData clientData; /* Information about button. */ + Tcl_Interp *interp; /* Interpreter containing variable. */ + char *name1; /* Not used. */ + char *name2; /* Not used. */ + int flags; /* Information about what happened. */ +{ + Listbox *listPtr = (Listbox *)clientData; + Tcl_Obj *oldListObj, *varListObj; + int oldLength; + int i; + Tcl_HashEntry *entry; + + /* Bwah hahahaha -- puny mortal, you can't unset a -listvar'd variable! */ + if (flags & TCL_TRACE_UNSETS) { + if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) { + Tcl_SetVar2Ex(interp, listPtr->listVarName, + (char *)NULL, listPtr->listObj, TCL_GLOBAL_ONLY); + Tcl_TraceVar(interp, listPtr->listVarName, + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + ListboxListVarProc, clientData); + return (char *)NULL; + } + } else { + oldListObj = listPtr->listObj; + varListObj = Tcl_GetVar2Ex(listPtr->interp, listPtr->listVarName, + (char *)NULL, TCL_GLOBAL_ONLY); + /* + * Make sure the new value is a good list; if it's not, disallow + * the change -- the fact that it is a listvar means that it must + * always be a valid list -- and return an error message. + */ + if (Tcl_ListObjLength(listPtr->interp, varListObj, &i) != TCL_OK) { + Tcl_SetVar2Ex(interp, listPtr->listVarName, (char *)NULL, + oldListObj, TCL_GLOBAL_ONLY); + return("invalid listvar value"); + } + + listPtr->listObj = varListObj; + /* Incr the obj ref count so it doesn't vanish if the var is unset */ + Tcl_IncrRefCount(listPtr->listObj); + /* Clean up the ref to our old list obj */ + Tcl_DecrRefCount(oldListObj); + } + + /* + * If the list length has decreased, then we should clean up selection and + * attributes information for elements past the end of the new list + */ + oldLength = listPtr->nElements; + Tcl_ListObjLength(listPtr->interp, listPtr->listObj, &listPtr->nElements); + if (listPtr->nElements < oldLength) { + for (i = listPtr->nElements; i < oldLength; i++) { + /* Clean up selection */ + entry = Tcl_FindHashEntry(listPtr->selection, (char *)i); + if (entry != NULL) { + listPtr->numSelected--; + Tcl_DeleteHashEntry(entry); + } + + /* Clean up attributes */ + entry = Tcl_FindHashEntry(listPtr->itemAttrTable, (char *)i); + if (entry != NULL) { + Tcl_DeleteHashEntry(entry); + } + } + } + + if (oldLength != listPtr->nElements) { + listPtr->flags |= UPDATE_V_SCROLLBAR; + if (listPtr->topIndex > (listPtr->nElements - listPtr->fullLines)) { + listPtr->topIndex = listPtr->nElements - listPtr->fullLines; + if (listPtr->topIndex < 0) { + listPtr->topIndex = 0; + } + } + } + + /* + * The computed maxWidth may have changed as a result of this operation. + * However, we don't want to recompute it every time this trace fires + * (imagine the user doing 1000 lappends to the listvar). Therefore, set + * the MAXWIDTH_IS_STALE flag, which will cause the width to be recomputed + * next time the list is redrawn. + */ + listPtr->flags |= MAXWIDTH_IS_STALE; + + EventuallyRedrawRange(listPtr, 0, listPtr->nElements-1); + return (char*)NULL; +} + +/* + *---------------------------------------------------------------------- + * + * MigrateHashEntries -- + * + * Given a hash table with entries keyed by a single integer value, + * move all entries in a given range by a fixed amount, so that + * if in the original table there was an entry with key n and + * the offset was i, in the new table that entry would have key n + i. + * + * Results: + * None. + * + * Side effects: + * Rekeys some hash table entries. + * + *---------------------------------------------------------------------- + */ + +static void +MigrateHashEntries(table, first, last, offset) + Tcl_HashTable *table; + int first; + int last; + int offset; +{ + int i, new; + Tcl_HashEntry *entry; + ClientData clientData; + + if (offset == 0) { + return; + } + /* It's more efficient to do one if/else and nest the for loops inside, + * although we could avoid some code duplication if we nested the if/else + * inside the for loops */ + if (offset > 0) { + for (i = last; i >= first; i--) { + entry = Tcl_FindHashEntry(table, (char *)i); + if (entry != NULL) { + clientData = Tcl_GetHashValue(entry); + Tcl_DeleteHashEntry(entry); + entry = Tcl_CreateHashEntry(table, (char *)(i + offset), &new); + Tcl_SetHashValue(entry, clientData); + } + } + } else { + for (i = first; i <= last; i++) { + entry = Tcl_FindHashEntry(table, (char *)i); + if (entry != NULL) { + clientData = Tcl_GetHashValue(entry); + Tcl_DeleteHashEntry(entry); + entry = Tcl_CreateHashEntry(table, (char *)(i + offset), &new); + Tcl_SetHashValue(entry, clientData); + } + } + } + return; +} + + +/* End of tklistbox.c */