diff options
Diffstat (limited to 'tk8.6/generic/tkListbox.c')
| -rw-r--r-- | tk8.6/generic/tkListbox.c | 3662 |
1 files changed, 0 insertions, 3662 deletions
diff --git a/tk8.6/generic/tkListbox.c b/tk8.6/generic/tkListbox.c deleted file mode 100644 index 5f650fe..0000000 --- a/tk8.6/generic/tkListbox.c +++ /dev/null @@ -1,3662 +0,0 @@ -/* - * 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. - */ - -#include "default.h" -#include "tkInt.h" - -#ifdef _WIN32 -#include "tkWinInt.h" -#endif - -typedef struct { - Tk_OptionTable listboxOptionTable; - /* Table defining configuration options - * available for the listbox. */ - Tk_OptionTable itemAttrOptionTable; - /* Table defining 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. */ - XColor *dfgColorPtr; /* Text color in disabled 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 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 - * visible. */ - 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). This is x scrolling information - * is not linked to justification. */ - - /* - * 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. */ - int activeStyle; /* Style in which to draw the active element. - * One of: underline, none, dotbox */ - - /* - * 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 state; /* Listbox state. */ - Pixmap gray; /* Pixmap for displaying disabled text. */ - int flags; /* Various flag bits: see below for - * definitions. */ - Tk_Justify justify; /* Justification. */ -} Listbox; - -/* - * How to encode the keys for the hash tables used to store what items are - * selected and what the attributes are. - */ - -#define KEY(i) ((char *) INT2PTR(i)) - -/* - * 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 following enum is used to define a type for the -state option of the - * Listbox widget. These values are used as indices into the string table - * below. - */ - -enum state { - STATE_DISABLED, STATE_NORMAL -}; - -static const char *const stateStrings[] = { - "disabled", "normal", NULL -}; - -enum activeStyle { - ACTIVE_STYLE_DOTBOX, ACTIVE_STYLE_NONE, ACTIVE_STYLE_UNDERLINE -}; - -static const char *const activeStyleStrings[] = { - "dotbox", "none", "underline", NULL -}; - -/* - * The optionSpecs table defines the valid configuration options for the - * listbox widget. - */ - -static const Tk_OptionSpec optionSpecs[] = { - {TK_OPTION_STRING_TABLE, "-activestyle", "activeStyle", "ActiveStyle", - DEF_LISTBOX_ACTIVE_STYLE, -1, Tk_Offset(Listbox, activeStyle), - 0, activeStyleStrings, 0}, - {TK_OPTION_BORDER, "-background", "background", "Background", - DEF_LISTBOX_BG_COLOR, -1, Tk_Offset(Listbox, normalBorder), - 0, DEF_LISTBOX_BG_MONO, 0}, - {TK_OPTION_SYNONYM, "-bd", NULL, NULL, - NULL, 0, -1, 0, "-borderwidth", 0}, - {TK_OPTION_SYNONYM, "-bg", NULL, NULL, - NULL, 0, -1, 0, "-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_COLOR, "-disabledforeground", "disabledForeground", - "DisabledForeground", DEF_LISTBOX_DISABLED_FG, -1, - Tk_Offset(Listbox, dfgColorPtr), 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", NULL, - NULL, 0, -1, 0, "-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_JUSTIFY, "-justify", "justify", "Justify", - DEF_LISTBOX_JUSTIFY, -1, Tk_Offset(Listbox, justify), 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, 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), - TK_OPTION_NULL_OK, 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_TABLE, "-state", "state", "State", - DEF_LISTBOX_STATE, -1, Tk_Offset(Listbox, state), - 0, stateStrings, 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, NULL, NULL, NULL, NULL, 0, -1, 0, 0, 0} -}; - -/* - * The itemAttrOptionSpecs table defines the valid configuration options for - * listbox items. - */ - -static const Tk_OptionSpec itemAttrOptionSpecs[] = { - {TK_OPTION_BORDER, "-background", "background", "Background", - NULL, -1, Tk_Offset(ItemAttr, border), - TK_OPTION_NULL_OK|TK_OPTION_DONT_SET_DEFAULT, - DEF_LISTBOX_BG_MONO, 0}, - {TK_OPTION_SYNONYM, "-bg", NULL, NULL, - NULL, 0, -1, 0, "-background", 0}, - {TK_OPTION_SYNONYM, "-fg", "foreground", NULL, - NULL, 0, -1, 0, "-foreground", 0}, - {TK_OPTION_COLOR, "-foreground", "foreground", "Foreground", - NULL, -1, Tk_Offset(ItemAttr, fgColor), - TK_OPTION_NULL_OK|TK_OPTION_DONT_SET_DEFAULT, 0, 0}, - {TK_OPTION_BORDER, "-selectbackground", "selectBackground", "Foreground", - NULL, -1, Tk_Offset(ItemAttr, selBorder), - TK_OPTION_NULL_OK|TK_OPTION_DONT_SET_DEFAULT, - DEF_LISTBOX_SELECT_MONO, 0}, - {TK_OPTION_COLOR, "-selectforeground", "selectForeground", "Background", - NULL, -1, Tk_Offset(ItemAttr, selFgColor), - TK_OPTION_NULL_OK|TK_OPTION_DONT_SET_DEFAULT, - DEF_LISTBOX_SELECT_FG_MONO, 0}, - {TK_OPTION_END, NULL, NULL, NULL, 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 const char *const commandNames[] = { - "activate", "bbox", "cget", "configure", "curselection", "delete", "get", - "index", "insert", "itemcget", "itemconfigure", "nearest", "scan", - "see", "selection", "size", "xview", "yview", 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 const char *const selCommandNames[] = { - "anchor", "clear", "includes", "set", NULL -}; -enum selcommand { - SELECTION_ANCHOR, SELECTION_CLEAR, SELECTION_INCLUDES, SELECTION_SET -}; - -static const char *const scanCommandNames[] = { - "mark", "dragto", NULL -}; -enum scancommand { - SCAN_MARK, SCAN_DRAGTO -}; - -static const char *const indexNames[] = { - "active", "anchor", "end", NULL -}; -enum indices { - INDEX_ACTIVE, INDEX_ANCHOR, INDEX_END -}; - -/* - * Declarations for procedures defined later in this file. - */ - -static void ChangeListboxOffset(Listbox *listPtr, int offset); -static void ChangeListboxView(Listbox *listPtr, int index); -static int ConfigureListbox(Tcl_Interp *interp, Listbox *listPtr, - int objc, Tcl_Obj *const objv[]); -static int ConfigureListboxItem(Tcl_Interp *interp, - Listbox *listPtr, ItemAttr *attrs, int objc, - Tcl_Obj *const objv[], int index); -static int ListboxDeleteSubCmd(Listbox *listPtr, - int first, int last); -static void DestroyListbox(void *memPtr); -static void DestroyListboxOptionTables(ClientData clientData, - Tcl_Interp *interp); -static void DisplayListbox(ClientData clientData); -static int GetListboxIndex(Tcl_Interp *interp, Listbox *listPtr, - Tcl_Obj *index, int endIsSize, int *indexPtr); -static int ListboxInsertSubCmd(Listbox *listPtr, - int index, int objc, Tcl_Obj *const objv[]); -static void ListboxCmdDeletedProc(ClientData clientData); -static void ListboxComputeGeometry(Listbox *listPtr, - int fontChanged, int maxIsStale, int updateGrid); -static void ListboxEventProc(ClientData clientData, - XEvent *eventPtr); -static int ListboxFetchSelection(ClientData clientData, - int offset, char *buffer, int maxBytes); -static void ListboxLostSelection(ClientData clientData); -static void GenerateListboxSelectEvent(Listbox *listPtr); -static void EventuallyRedrawRange(Listbox *listPtr, - int first, int last); -static void ListboxScanTo(Listbox *listPtr, int x, int y); -static int ListboxSelect(Listbox *listPtr, - int first, int last, int select); -static void ListboxUpdateHScrollbar(Listbox *listPtr); -static void ListboxUpdateVScrollbar(Listbox *listPtr); -static int ListboxWidgetObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); -static int ListboxBboxSubCmd(Tcl_Interp *interp, - Listbox *listPtr, int index); -static int ListboxSelectionSubCmd(Tcl_Interp *interp, - Listbox *listPtr, int objc, Tcl_Obj *const objv[]); -static int ListboxXviewSubCmd(Tcl_Interp *interp, - Listbox *listPtr, int objc, Tcl_Obj *const objv[]); -static int ListboxYviewSubCmd(Tcl_Interp *interp, - Listbox *listPtr, int objc, Tcl_Obj *const objv[]); -static ItemAttr * ListboxGetItemAttributes(Tcl_Interp *interp, - Listbox *listPtr, int index); -static void ListboxWorldChanged(ClientData instanceData); -static int NearestListboxElement(Listbox *listPtr, int y); -static char * ListboxListVarProc(ClientData clientData, - Tcl_Interp *interp, const char *name1, - const char *name2, int flags); -static void MigrateHashEntries(Tcl_HashTable *table, - int first, int last, int offset); -static int GetMaxOffset(Listbox *listPtr); - -/* - * The structure below defines button class behavior by means of procedures - * that can be invoked from generic window code. - */ - -static const Tk_ClassProcs listboxClass = { - sizeof(Tk_ClassProcs), /* size */ - ListboxWorldChanged, /* worldChangedProc */ - NULL, /* createProc */ - 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 clientData, /* NULL. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - register Listbox *listPtr; - Tk_Window tkwin; - ListboxOptionTables *optionTables; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "pathName ?-option value ...?"); - return TCL_ERROR; - } - - tkwin = Tk_CreateWindowFromPath(interp, Tk_MainWindow(interp), - Tcl_GetString(objv[1]), NULL); - if (tkwin == NULL) { - return TCL_ERROR; - } - - optionTables = Tcl_GetAssocData(interp, "ListboxOptionTables", NULL); - if (optionTables == NULL) { - /* - * 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 = ckalloc(sizeof(ListboxOptionTables)); - - /* - * Set up an exit handler to free the optionTables struct. - */ - - Tcl_SetAssocData(interp, "ListboxOptionTables", - DestroyListboxOptionTables, optionTables); - - /* - * Create the listbox option table and the listbox item option table. - */ - - optionTables->listboxOptionTable = - Tk_CreateOptionTable(interp, optionSpecs); - optionTables->itemAttrOptionTable = - Tk_CreateOptionTable(interp, itemAttrOptionSpecs); - } - - /* - * 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 = ckalloc(sizeof(Listbox)); - memset(listPtr, 0, sizeof(Listbox)); - - listPtr->tkwin = tkwin; - listPtr->display = Tk_Display(tkwin); - listPtr->interp = interp; - listPtr->widgetCmd = Tcl_CreateObjCommand(interp, - Tk_PathName(listPtr->tkwin), ListboxWidgetObjCmd, listPtr, - ListboxCmdDeletedProc); - listPtr->optionTable = optionTables->listboxOptionTable; - listPtr->itemAttrOptionTable = optionTables->itemAttrOptionTable; - listPtr->selection = ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(listPtr->selection, TCL_ONE_WORD_KEYS); - listPtr->itemAttrTable = ckalloc(sizeof(Tcl_HashTable)); - Tcl_InitHashTable(listPtr->itemAttrTable, TCL_ONE_WORD_KEYS); - listPtr->relief = TK_RELIEF_RAISED; - listPtr->textGC = None; - listPtr->selFgColorPtr = None; - listPtr->selTextGC = None; - listPtr->fullLines = 1; - listPtr->xScrollUnit = 1; - listPtr->exportSelection = 1; - listPtr->cursor = None; - listPtr->state = STATE_NORMAL; - listPtr->gray = None; - listPtr->justify = TK_JUSTIFY_LEFT; - - /* - * Keep a hold of the associated tkwin until we destroy the listbox, - * otherwise Tk might free it while we still need it. - */ - - Tcl_Preserve(listPtr->tkwin); - - Tk_SetClass(listPtr->tkwin, "Listbox"); - Tk_SetClassProcs(listPtr->tkwin, &listboxClass, listPtr); - Tk_CreateEventHandler(listPtr->tkwin, - ExposureMask|StructureNotifyMask|FocusChangeMask, - ListboxEventProc, listPtr); - Tk_CreateSelHandler(listPtr->tkwin, XA_PRIMARY, XA_STRING, - ListboxFetchSelection, 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) != TCL_OK) { - Tk_DestroyWindow(listPtr->tkwin); - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, TkNewWindowObj(listPtr->tkwin)); - 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 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 = clientData; - int cmdIndex, index; - int result = TCL_OK; - Tcl_Obj *objPtr; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); - return TCL_ERROR; - } - - /* - * 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) { - return result; - } - - Tcl_Preserve(listPtr); - - /* - * 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 (!(listPtr->state & STATE_NORMAL)) { - 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: - 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: - if (objc <= 3) { - objPtr = Tk_GetOptionInfo(interp, (char *) listPtr, - listPtr->optionTable, - (objc == 3) ? objv[2] : NULL, listPtr->tkwin); - if (objPtr == NULL) { - result = TCL_ERROR; - break; - } - Tcl_SetObjResult(interp, objPtr); - result = TCL_OK; - } else { - result = ConfigureListbox(interp, listPtr, objc-2, objv+2); - } - break; - - case COMMAND_CURSELECTION: { - 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. - */ - - objPtr = Tcl_NewObj(); - for (i = 0; i < listPtr->nElements; i++) { - if (Tcl_FindHashEntry(listPtr->selection, KEY(i))) { - Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewIntObj(i)); - } - } - Tcl_SetObjResult(interp, objPtr); - 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 (!(listPtr->state & STATE_NORMAL)) { - 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, listLen; - Tcl_Obj **elemPtrs; - - 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_SetObjResult(interp, - Tcl_NewListObj(last-first+1, elemPtrs+first)); - } - result = TCL_OK; - break; - } - - case COMMAND_INDEX: - 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; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(index)); - result = TCL_OK; - break; - - case COMMAND_INSERT: - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "index ?element ...?"); - result = TCL_ERROR; - break; - } - - result = GetListboxIndex(interp, listPtr, objv[2], 1, &index); - if (result != TCL_OK) { - break; - } - - if (!(listPtr->state & STATE_NORMAL)) { - break; - } - - result = ListboxInsertSubCmd(listPtr, index, objc-3, objv+3); - break; - - case COMMAND_ITEMCGET: { - 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_SetObjResult(interp, Tcl_ObjPrintf( - "item number \"%s\" out of range", - Tcl_GetString(objv[2]))); - Tcl_SetErrorCode(interp, "TK", "LISTBOX", "ITEM_INDEX", 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: { - 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_SetObjResult(interp, Tcl_ObjPrintf( - "item number \"%s\" out of range", - Tcl_GetString(objv[2]))); - Tcl_SetErrorCode(interp, "TK", "LISTBOX", "ITEM_INDEX", 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] : NULL, listPtr->tkwin); - if (objPtr == NULL) { - result = TCL_ERROR; - break; - } - Tcl_SetObjResult(interp, objPtr); - result = TCL_OK; - } else { - result = ConfigureListboxItem(interp, listPtr, attrPtr, - objc-3, objv+3, index); - } - break; - } - - case COMMAND_NEAREST: { - 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); - Tcl_SetObjResult(interp, Tcl_NewIntObj(index)); - 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: - if (objc != 2) { - Tcl_WrongNumArgs(interp, 2, objv, NULL); - result = TCL_ERROR; - break; - } - Tcl_SetObjResult(interp, Tcl_NewIntObj(listPtr->nElements)); - 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(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( - 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 */ -{ - register Tk_Window tkwin = listPtr->tkwin; - 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)) { - Tcl_Obj *el, *results[4]; - const 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); - - if (listPtr->justify == TK_JUSTIFY_LEFT) { - x = (listPtr->inset + listPtr->selBorderWidth) - listPtr->xOffset; - } else if (listPtr->justify == TK_JUSTIFY_RIGHT) { - x = Tk_Width(tkwin) - (listPtr->inset + listPtr->selBorderWidth) - - pixelWidth - listPtr->xOffset + GetMaxOffset(listPtr); - } else { - x = (Tk_Width(tkwin) - pixelWidth)/2 - - listPtr->xOffset + GetMaxOffset(listPtr)/2; - } - y = ((index - listPtr->topIndex)*listPtr->lineHeight) - + listPtr->inset + listPtr->selBorderWidth; - results[0] = Tcl_NewIntObj(x); - results[1] = Tcl_NewIntObj(y); - results[2] = Tcl_NewIntObj(pixelWidth); - results[3] = Tcl_NewIntObj(fm.linespace); - Tcl_SetObjResult(interp, Tcl_NewListObj(4, results)); - } - 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( - 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; - } - - /* - * Only allow 'selection includes' to respond if disabled. [Bug #632514] - */ - - if ((listPtr->state == STATE_DISABLED) - && (selCmdIndex != SELECTION_INCLUDES)) { - return TCL_OK; - } - - 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; - } - Tcl_SetObjResult(interp, Tcl_NewBooleanObj( - Tcl_FindHashEntry(listPtr->selection, KEY(first)) != NULL)); - 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( - 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, windowWidth, windowUnits; - int offset = 0; /* Initialized to stop gcc warnings. */ - double fraction; - - windowWidth = Tk_Width(listPtr->tkwin) - - 2*(listPtr->inset + listPtr->selBorderWidth); - if (objc == 2) { - Tcl_Obj *results[2]; - - if (listPtr->maxWidth == 0) { - results[0] = Tcl_NewDoubleObj(0.0); - results[1] = Tcl_NewDoubleObj(1.0); - } else { - double fraction2; - - fraction = listPtr->xOffset / (double) listPtr->maxWidth; - fraction2 = (listPtr->xOffset + windowWidth) - / (double) listPtr->maxWidth; - if (fraction2 > 1.0) { - fraction2 = 1.0; - } - results[0] = Tcl_NewDoubleObj(fraction); - results[1] = Tcl_NewDoubleObj(fraction2); - } - Tcl_SetObjResult(interp, Tcl_NewListObj(2, results)); - } else if (objc == 3) { - if (Tcl_GetIntFromObj(interp, objv[2], &index) != TCL_OK) { - return TCL_ERROR; - } - ChangeListboxOffset(listPtr, index*listPtr->xScrollUnit); - } else { - switch (Tk_GetScrollInfoObj(interp, objc, objv, &fraction, &count)) { - 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( - 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; - double fraction; - - if (objc == 2) { - Tcl_Obj *results[2]; - - if (listPtr->nElements == 0) { - results[0] = Tcl_NewDoubleObj(0.0); - results[1] = Tcl_NewDoubleObj(1.0); - } else { - double fraction2, numEls = (double) listPtr->nElements; - - fraction = listPtr->topIndex / numEls; - fraction2 = (listPtr->topIndex+listPtr->fullLines) / numEls; - if (fraction2 > 1.0) { - fraction2 = 1.0; - } - results[0] = Tcl_NewDoubleObj(fraction); - results[1] = Tcl_NewDoubleObj(fraction2); - } - Tcl_SetObjResult(interp, Tcl_NewListObj(2, results)); - } else if (objc == 3) { - if (GetListboxIndex(interp, listPtr, objv[2], 0, &index) != TCL_OK) { - return TCL_ERROR; - } - ChangeListboxView(listPtr, index); - } else { - switch (Tk_GetScrollInfoObj(interp, objc, objv, &fraction, &count)) { - 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; - case TK_SCROLL_ERROR: - default: - return TCL_ERROR; - } - 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( - 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 isNew; - Tcl_HashEntry *entry; - ItemAttr *attrs; - - entry = Tcl_CreateHashEntry(listPtr->itemAttrTable, KEY(index), &isNew); - if (isNew) { - attrs = 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, attrs); - } else { - attrs = 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( - void *memPtr) /* Info about listbox widget. */ -{ - register Listbox *listPtr = memPtr; - Tcl_HashEntry *entry; - Tcl_HashSearch search; - - /* - * 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_UntraceVar2(listPtr->interp, listPtr->listVarName, NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - ListboxListVarProc, listPtr); - } - - /* - * Free the selection hash table. - */ - - Tcl_DeleteHashTable(listPtr->selection); - ckfree(listPtr->selection); - - /* - * Free the item attribute hash table. - */ - - for (entry = Tcl_FirstHashEntry(listPtr->itemAttrTable, &search); - entry != NULL; entry = Tcl_NextHashEntry(&search)) { - ckfree(Tcl_GetHashValue(entry)); - } - Tcl_DeleteHashTable(listPtr->itemAttrTable); - ckfree(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); - } - if (listPtr->gray != None) { - Tk_FreeBitmap(Tk_Display(listPtr->tkwin), listPtr->gray); - } - - Tk_FreeConfigOptions((char *) listPtr, listPtr->optionTable, - listPtr->tkwin); - Tcl_Release(listPtr->tkwin); - listPtr->tkwin = NULL; - ckfree(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 clientData, /* Pointer to the OptionTables struct */ - Tcl_Interp *interp) /* Pointer to the calling interp */ -{ - ckfree(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( - 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. */ -{ - Tk_SavedOptions savedOptions; - Tcl_Obj *oldListObj = NULL; - Tcl_Obj *errorResult = NULL; - int oldExport, error; - - oldExport = (listPtr->exportSelection) && (!Tcl_IsSafe(listPtr->interp)); - if (listPtr->listVarName != NULL) { - Tcl_UntraceVar2(interp, listPtr->listVarName, NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - ListboxListVarProc, listPtr); - } - - for (error = 0; error <= 1; error++) { - if (!error) { - /* - * First pass: set options to new values. - */ - - if (Tk_SetOptions(interp, (char *) listPtr, - listPtr->optionTable, objc, objv, - listPtr->tkwin, &savedOptions, NULL) != TCL_OK) { - continue; - } - } else { - /* - * Second pass: restore options to old values. - */ - - errorResult = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(errorResult); - Tk_RestoreSavedOptions(&savedOptions); - } - - /* - * 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 and this interp is unsafe. - */ - - if (listPtr->exportSelection && (!oldExport) - && (!Tcl_IsSafe(listPtr->interp)) - && (listPtr->numSelected != 0)) { - Tk_OwnSelection(listPtr->tkwin, XA_PRIMARY, - ListboxLostSelection, 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, - NULL, TCL_GLOBAL_ONLY); - int dummy; - - if (listVarObj == NULL) { - listVarObj = (oldListObj ? oldListObj : Tcl_NewObj()); - if (Tcl_SetVar2Ex(interp, listPtr->listVarName, NULL, - listVarObj, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) - == NULL) { - continue; - } - } - - /* - * Make sure the object is a good list object. - */ - - if (Tcl_ListObjLength(listPtr->interp, listVarObj, &dummy) - != TCL_OK) { - Tcl_AppendResult(listPtr->interp, - ": invalid -listvariable value", NULL); - continue; - } - - listPtr->listObj = listVarObj; - Tcl_TraceVar2(listPtr->interp, listPtr->listVarName, - NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - ListboxListVarProc, listPtr); - } else if (listPtr->listObj == NULL) { - listPtr->listObj = Tcl_NewObj(); - } - Tcl_IncrRefCount(listPtr->listObj); - if (oldListObj != NULL) { - Tcl_DecrRefCount(oldListObj); - } - break; - } - if (!error) { - Tk_FreeSavedOptions(&savedOptions); - } - - /* - * Make sure that the list length is correct. - */ - - Tcl_ListObjLength(listPtr->interp, listPtr->listObj, &listPtr->nElements); - - if (error) { - Tcl_SetObjResult(interp, errorResult); - Tcl_DecrRefCount(errorResult); - return TCL_ERROR; - } - ListboxWorldChanged(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( - 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. */ - int index) /* Index of the listbox item being configure */ -{ - Tk_SavedOptions savedOptions; - - if (Tk_SetOptions(interp, (char *)attrs, - listPtr->itemAttrOptionTable, objc, objv, listPtr->tkwin, - &savedOptions, NULL) != TCL_OK) { - Tk_RestoreSavedOptions(&savedOptions); - return TCL_ERROR; - } - Tk_FreeSavedOptions(&savedOptions); - - /* - * Redraw this index - ListboxWorldChanged would need to be called if item - * attributes were checked in the "world". - */ - - EventuallyRedrawRange(listPtr, index, index); - 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( - ClientData instanceData) /* Information about widget. */ -{ - XGCValues gcValues; - GC gc; - unsigned long mask; - Listbox *listPtr = instanceData; - - if (listPtr->state & STATE_NORMAL) { - gcValues.foreground = listPtr->fgColorPtr->pixel; - gcValues.graphics_exposures = False; - mask = GCForeground | GCFont | GCGraphicsExposures; - } else if (listPtr->dfgColorPtr != NULL) { - gcValues.foreground = listPtr->dfgColorPtr->pixel; - gcValues.graphics_exposures = False; - mask = GCForeground | GCFont | GCGraphicsExposures; - } else { - gcValues.foreground = listPtr->fgColorPtr->pixel; - mask = GCForeground | GCFont; - if (listPtr->gray == None) { - listPtr->gray = Tk_GetBitmap(NULL, listPtr->tkwin, "gray50"); - } - if (listPtr->gray != None) { - gcValues.fill_style = FillStippled; - gcValues.stipple = listPtr->gray; - mask |= GCFillStyle | GCStipple; - } - } - - gcValues.font = Tk_FontId(listPtr->tkfont); - gc = Tk_GetGC(listPtr->tkwin, mask, &gcValues); - if (listPtr->textGC != None) { - Tk_FreeGC(listPtr->display, listPtr->textGC); - } - listPtr->textGC = gc; - - if (listPtr->selFgColorPtr != NULL) { - 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) /* Information about window. */ -{ - register Listbox *listPtr = clientData; - register Tk_Window tkwin = listPtr->tkwin; - GC gc; - int i, limit, x, y, prevSelected, freeGC, stringLen; - Tk_FontMetrics fm; - Tcl_Obj *curElement; - Tcl_HashEntry *entry; - const char *stringRep; - 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; - int textWidth; - - listPtr->flags &= ~REDRAW_PENDING; - if (listPtr->flags & LISTBOX_DELETED) { - return; - } - - if (listPtr->flags & MAXWIDTH_IS_STALE) { - ListboxComputeGeometry(listPtr, 0, 1, 0); - listPtr->flags &= ~MAXWIDTH_IS_STALE; - listPtr->flags |= UPDATE_H_SCROLLBAR; - } - - Tcl_Preserve(listPtr); - if (listPtr->flags & UPDATE_V_SCROLLBAR) { - ListboxUpdateVScrollbar(listPtr); - if ((listPtr->flags & LISTBOX_DELETED) || !Tk_IsMapped(tkwin)) { - Tcl_Release(listPtr); - return; - } - } - if (listPtr->flags & UPDATE_H_SCROLLBAR) { - ListboxUpdateHScrollbar(listPtr); - if ((listPtr->flags & LISTBOX_DELETED) || !Tk_IsMapped(tkwin)) { - Tcl_Release(listPtr); - return; - } - } - listPtr->flags &= ~(REDRAW_PENDING|UPDATE_V_SCROLLBAR|UPDATE_H_SCROLLBAR); - Tcl_Release(listPtr); - -#ifndef TK_NO_DOUBLE_BUFFERING - /* - * 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)); -#else - pixmap = Tk_WindowId(tkwin); -#endif /* TK_NO_DOUBLE_BUFFERING */ - 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++) { - int width = Tk_Width(tkwin); /* zeroth approx to silence warning */ - - x = listPtr->inset; - y = ((i - listPtr->topIndex) * listPtr->lineHeight) + listPtr->inset; - gc = listPtr->textGC; - freeGC = 0; - - /* - * Lookup this item in the item attributes table, to see if it has - * special foreground/background colors. - */ - - entry = Tcl_FindHashEntry(listPtr->itemAttrTable, KEY(i)); - - /* - * If the listbox is enabled, items may be drawn differently; they may - * be drawn selected, or they may have special foreground or - * background colors. - */ - - if (listPtr->state & STATE_NORMAL) { - if (Tcl_FindHashEntry(listPtr->selection, KEY(i))) { - /* - * Selected items are drawn differently. - */ - - 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 = Tcl_GetHashValue(entry); - - /* - * Default GC has the values from the widget at large. - */ - - if (listPtr->selFgColorPtr) { - gcValues.foreground = listPtr->selFgColorPtr->pixel; - } else { - gcValues.foreground = listPtr->fgColorPtr->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); - freeGC = 1; - } - } - - 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" & "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" & "right" vars, 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, KEY(i + 1))) { - 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 = Tcl_GetHashValue(entry); - gcValues.foreground = listPtr->fgColorPtr->pixel; - gcValues.font = Tk_FontId(listPtr->tkfont); - gcValues.graphics_exposures = False; - mask = GCForeground | GCFont | GCGraphicsExposures; - - /* - * If the item has its own background color, draw it now. - */ - - 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 the item has its own foreground, use it to override - * the value in the gcValues structure. - */ - - if ((listPtr->state & STATE_NORMAL) - && attrs->fgColor != NULL) { - gcValues.foreground = attrs->fgColor->pixel; - gc = Tk_GetGC(listPtr->tkwin, mask, &gcValues); - freeGC = 1; - } - } - prevSelected = 0; - } - } - - /* - * Draw the actual text of this item. - */ - - Tcl_ListObjIndex(listPtr->interp, listPtr->listObj, i, &curElement); - stringRep = Tcl_GetStringFromObj(curElement, &stringLen); - textWidth = Tk_TextWidth(listPtr->tkfont, stringRep, stringLen); - - Tk_GetFontMetrics(listPtr->tkfont, &fm); - y += fm.ascent + listPtr->selBorderWidth; - - if (listPtr->justify == TK_JUSTIFY_LEFT) { - x = (listPtr->inset + listPtr->selBorderWidth) - listPtr->xOffset; - } else if (listPtr->justify == TK_JUSTIFY_RIGHT) { - x = Tk_Width(tkwin) - (listPtr->inset + listPtr->selBorderWidth) - - textWidth - listPtr->xOffset + GetMaxOffset(listPtr); - } else { - x = (Tk_Width(tkwin) - textWidth)/2 - - listPtr->xOffset + GetMaxOffset(listPtr)/2; - } - - Tk_DrawChars(listPtr->display, pixmap, gc, listPtr->tkfont, - stringRep, stringLen, x, y); - - /* - * If this is the active element, apply the activestyle to it. - */ - - if ((i == listPtr->active) && (listPtr->flags & GOT_FOCUS)) { - if (listPtr->activeStyle == ACTIVE_STYLE_UNDERLINE) { - /* - * Underline the text. - */ - - Tk_UnderlineChars(listPtr->display, pixmap, gc, - listPtr->tkfont, stringRep, x, y, 0, stringLen); - } else if (listPtr->activeStyle == ACTIVE_STYLE_DOTBOX) { -#ifdef _WIN32 - /* - * This provides for exact default look and feel on Windows. - */ - - TkWinDCState state; - HDC dc; - RECT rect; - - dc = TkWinGetDrawableDC(listPtr->display, pixmap, &state); - rect.left = listPtr->inset; - rect.top = ((i - listPtr->topIndex) * listPtr->lineHeight) - + listPtr->inset; - rect.right = rect.left + width; - rect.bottom = rect.top + listPtr->lineHeight; - DrawFocusRect(dc, &rect); - TkWinReleaseDrawableDC(pixmap, dc, &state); -#else /* !_WIN32 */ - /* - * Draw a dotted box around the text. - */ - - x = listPtr->inset; - y = ((i - listPtr->topIndex) * listPtr->lineHeight) - + listPtr->inset; - width = Tk_Width(tkwin) - 2*listPtr->inset - 1; - - gcValues.line_style = LineOnOffDash; - gcValues.line_width = listPtr->selBorderWidth; - if (gcValues.line_width <= 0) { - gcValues.line_width = 1; - } - gcValues.dash_offset = 0; - gcValues.dashes = 1; - - /* - * You would think the XSetDashes was necessary, but it - * appears that the default dotting for just saying we want - * dashes appears to work correctly. - static char dashList[] = { 1 }; - static int dashLen = sizeof(dashList); - XSetDashes(listPtr->display, gc, 0, dashList, dashLen); - */ - - mask = GCLineWidth | GCLineStyle | GCDashList | GCDashOffset; - XChangeGC(listPtr->display, gc, mask, &gcValues); - XDrawRectangle(listPtr->display, pixmap, gc, x, y, - (unsigned) width, (unsigned) listPtr->lineHeight - 1); - if (!freeGC) { - /* - * Don't bother changing if it is about to be freed. - */ - - gcValues.line_style = LineSolid; - XChangeGC(listPtr->display, gc, GCLineStyle, &gcValues); - } -#endif /* _WIN32 */ - } - } - - if (freeGC) { - Tk_FreeGC(listPtr->display, gc); - } - } - - /* - * 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); - } - } -#ifndef TK_NO_DOUBLE_BUFFERING - 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); -#endif /* TK_NO_DOUBLE_BUFFERING */ -} - -/* - *---------------------------------------------------------------------- - * - * 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( - 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, textLength, i, result; - Tk_FontMetrics fm; - Tcl_Obj *element; - const char *text; - - 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( - 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, pixelWidth, result, length; - Tcl_Obj *newListObj; - const char *stringRep; - - 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; - } - - /* - * Replace the current object and set attached listvar, if any. This may - * error if listvar points to a var in a deleted namespace, but we ignore - * those errors. If the namespace is recreated, it will auto-sync with the - * current value. [Bug 1424513] - */ - - Tcl_IncrRefCount(newListObj); - Tcl_DecrRefCount(listPtr->listObj); - listPtr->listObj = newListObj; - if (listPtr->listVarName != NULL) { - Tcl_SetVar2Ex(listPtr->interp, listPtr->listVarName, NULL, - listPtr->listObj, TCL_GLOBAL_ONLY); - } - - /* - * 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( - 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, length, result, pixelWidth; - Tcl_Obj *newListObj, *element; - const char *stringRep; - 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, KEY(i)); - if (entry != NULL) { - listPtr->numSelected--; - Tcl_DeleteHashEntry(entry); - } - - entry = Tcl_FindHashEntry(listPtr->itemAttrTable, KEY(i)); - if (entry != NULL) { - ckfree(Tcl_GetHashValue(entry)); - 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; - } - - /* - * Replace the current object and set attached listvar, if any. This may - * error if listvar points to a var in a deleted namespace, but we ignore - * those errors. If the namespace is recreated, it will auto-sync with the - * current value. [Bug 1424513] - */ - - Tcl_IncrRefCount(newListObj); - Tcl_DecrRefCount(listPtr->listObj); - listPtr->listObj = newListObj; - if (listPtr->listVarName != NULL) { - Tcl_SetVar2Ex(listPtr->interp, listPtr->listVarName, NULL, - listPtr->listObj, TCL_GLOBAL_ONLY); - } - - /* - * Get the new list length. - */ - - Tcl_ListObjLength(listPtr->interp, listPtr->listObj, &listPtr->nElements); - - /* - * 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 clientData, /* Information about window. */ - XEvent *eventPtr) /* Information about event. */ -{ - Listbox *listPtr = 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) { - if (!(listPtr->flags & LISTBOX_DELETED)) { - 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); - } - Tcl_EventuallyFree(clientData, (Tcl_FreeProc *) DestroyListbox); - } - } 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) /* Pointer to widget record for widget. */ -{ - Listbox *listPtr = 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( - 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, index; - const 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; - const char *start; - char *end; - - start = stringRep + 1; - y = strtol(start, &end, 0); - if ((start == end) || (*end != ',')) { - goto badIndex; - } - start = end+1; - y = strtol(start, &end, 0); - if ((start == end) || (*end != '\0')) { - goto badIndex; - } - *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. - */ - - badIndex: - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad listbox index \"%s\": must be active, anchor, end, @x,y," - " or a number", Tcl_GetString(indexObj))); - Tcl_SetErrorCode(interp, "TK", "VALUE", "LISTBOX_INDEX", 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( - 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( - 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. - * - * Add half a scroll unit to do entry/text-like synchronization. [Bug - * #225025] - */ - - offset += listPtr->xScrollUnit / 2; - maxOffset = GetMaxOffset(listPtr); - 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( - 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 = GetMaxOffset(listPtr); - - /* - * 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( - 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( - 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, oldCount, isNew; - Tcl_HashEntry *entry; - - 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; - - /* - * 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, KEY(i)); - if (entry != NULL) { - if (!select) { - Tcl_DeleteHashEntry(entry); - listPtr->numSelected--; - if (firstRedisplay < 0) { - firstRedisplay = i; - } - } - } else { - if (select) { - entry = Tcl_CreateHashEntry(listPtr->selection, KEY(i), - &isNew); - Tcl_SetHashValue(entry, NULL); - listPtr->numSelected++; - if (firstRedisplay < 0) { - firstRedisplay = i; - } - } - } - } - - if (firstRedisplay >= 0) { - EventuallyRedrawRange(listPtr, first, last); - } - if ((oldCount == 0) && (listPtr->numSelected > 0) - && (listPtr->exportSelection) - && (!Tcl_IsSafe(listPtr->interp))) { - Tk_OwnSelection(listPtr->tkwin, XA_PRIMARY, - ListboxLostSelection, 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 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 = clientData; - Tcl_DString selection; - int length, count, needNewline, stringLen, i; - Tcl_Obj *curElement; - const char *stringRep; - Tcl_HashEntry *entry; - - if ((!listPtr->exportSelection) || Tcl_IsSafe(listPtr->interp)) { - 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, KEY(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(buffer, 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) /* Information about listbox widget. */ -{ - register Listbox *listPtr = clientData; - - if ((listPtr->exportSelection) && (!Tcl_IsSafe(listPtr->interp)) - && (listPtr->nElements > 0)) { - ListboxSelect(listPtr, 0, listPtr->nElements-1, 0); - GenerateListboxSelectEvent(listPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * GenerateListboxSelectEvent -- - * - * Send an event that the listbox selection was updated. This is - * equivalent to event generate $listboxWidget <<ListboxSelect>> - * - * Results: - * None - * - * Side effects: - * Any side effect possible, depending on bindings to this event. - * - *---------------------------------------------------------------------- - */ - -static void -GenerateListboxSelectEvent( - Listbox *listPtr) /* Information about widget. */ -{ - TkSendVirtualEvent(listPtr->tkwin, "ListboxSelect", NULL); -} - -/* - *---------------------------------------------------------------------- - * - * 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( - 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->flags & LISTBOX_DELETED) - || !Tk_IsMapped(listPtr->tkwin)) { - return; - } - listPtr->flags |= REDRAW_PENDING; - Tcl_DoWhenIdle(DisplayListbox, 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( - register Listbox *listPtr) /* Information about widget. */ -{ - char firstStr[TCL_DOUBLE_SPACE], lastStr[TCL_DOUBLE_SPACE]; - double first, last; - int result; - Tcl_Interp *interp; - Tcl_DString buf; - - 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; - } - } - Tcl_PrintDouble(NULL, first, firstStr); - Tcl_PrintDouble(NULL, last, lastStr); - - /* - * 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(interp); - Tcl_DStringInit(&buf); - Tcl_DStringAppend(&buf, listPtr->yScrollCmd, -1); - Tcl_DStringAppend(&buf, " ", -1); - Tcl_DStringAppend(&buf, firstStr, -1); - Tcl_DStringAppend(&buf, " ", -1); - Tcl_DStringAppend(&buf, lastStr, -1); - result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0); - Tcl_DStringFree(&buf); - if (result != TCL_OK) { - Tcl_AddErrorInfo(interp, - "\n (vertical scrolling command executed by listbox)"); - Tcl_BackgroundException(interp, result); - } - Tcl_Release(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( - register Listbox *listPtr) /* Information about widget. */ -{ - char firstStr[TCL_DOUBLE_SPACE], lastStr[TCL_DOUBLE_SPACE]; - int result, windowWidth; - double first, last; - Tcl_Interp *interp; - Tcl_DString buf; - - 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; - } - } - Tcl_PrintDouble(NULL, first, firstStr); - Tcl_PrintDouble(NULL, last, lastStr); - - /* - * 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(interp); - Tcl_DStringInit(&buf); - Tcl_DStringAppend(&buf, listPtr->xScrollCmd, -1); - Tcl_DStringAppend(&buf, " ", -1); - Tcl_DStringAppend(&buf, firstStr, -1); - Tcl_DStringAppend(&buf, " ", -1); - Tcl_DStringAppend(&buf, lastStr, -1); - result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0); - Tcl_DStringFree(&buf); - if (result != TCL_OK) { - Tcl_AddErrorInfo(interp, - "\n (horizontal scrolling command executed by listbox)"); - Tcl_BackgroundException(interp, result); - } - Tcl_Release(interp); -} - -/* - *---------------------------------------------------------------------- - * - * ListboxListVarProc -- - * - * Called whenever the trace on the listbox list var fires. - * - * Results: - * None. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static char * -ListboxListVarProc( - ClientData clientData, /* Information about button. */ - Tcl_Interp *interp, /* Interpreter containing variable. */ - const char *name1, /* Name of variable. */ - const char *name2, /* Second part of variable name. */ - int flags) /* Information about what happened. */ -{ - Listbox *listPtr = clientData; - Tcl_Obj *oldListObj, *varListObj; - int oldLength, i; - Tcl_HashEntry *entry; - - /* - * See ticket [5d991b82]. - */ - - if (listPtr->listVarName == NULL) { - if (!(flags & TCL_INTERP_DESTROYED)) { - Tcl_UntraceVar2(interp, name1, name2, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - ListboxListVarProc, clientData); - } - return NULL; - } - - /* - * 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, NULL, - listPtr->listObj, TCL_GLOBAL_ONLY); - Tcl_TraceVar2(interp, listPtr->listVarName, - NULL, TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - ListboxListVarProc, clientData); - return NULL; - } - } else { - oldListObj = listPtr->listObj; - varListObj = Tcl_GetVar2Ex(listPtr->interp, listPtr->listVarName, - 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, NULL, oldListObj, - TCL_GLOBAL_ONLY); - return (char *) "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, KEY(i)); - if (entry != NULL) { - listPtr->numSelected--; - Tcl_DeleteHashEntry(entry); - } - - /* - * Clean up attributes. - */ - - entry = Tcl_FindHashEntry(listPtr->itemAttrTable, KEY(i)); - if (entry != NULL) { - ckfree(Tcl_GetHashValue(entry)); - 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 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( - Tcl_HashTable *table, - int first, - int last, - int offset) -{ - int i, isNew; - 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, KEY(i)); - if (entry != NULL) { - clientData = Tcl_GetHashValue(entry); - Tcl_DeleteHashEntry(entry); - entry = Tcl_CreateHashEntry(table, KEY(i + offset), &isNew); - Tcl_SetHashValue(entry, clientData); - } - } - } else { - for (i = first; i <= last; i++) { - entry = Tcl_FindHashEntry(table, KEY(i)); - if (entry != NULL) { - clientData = Tcl_GetHashValue(entry); - Tcl_DeleteHashEntry(entry); - entry = Tcl_CreateHashEntry(table, KEY(i + offset), &isNew); - Tcl_SetHashValue(entry, clientData); - } - } - } - return; -} - -/* - *---------------------------------------------------------------------- - * - * GetMaxOffset -- - * - * Passing in a listbox pointer, returns the maximum offset for the box, - * i.e. the maximum possible horizontal scrolling value (in pixels). - * - * Results: - * Listbox's maxOffset. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- -*/ -static int GetMaxOffset( - register Listbox *listPtr) -{ - int maxOffset; - - maxOffset = listPtr->maxWidth - - (Tk_Width(listPtr->tkwin) - 2*listPtr->inset - - 2*listPtr->selBorderWidth) + listPtr->xScrollUnit - 1; - if (maxOffset < 0) { - - /* - * Listbox is larger in width than its largest width item. - */ - - maxOffset = 0; - } - maxOffset -= maxOffset % listPtr->xScrollUnit; - - return maxOffset; -} -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ |