tkListbox.c
上传用户:rrhhcc
上传日期:2015-12-11
资源大小:54129k
文件大小:103k
- /*
- * tkListbox.c --
- *
- * This module implements listbox widgets for the Tk
- * toolkit. A listbox displays a collection of strings,
- * one per line, and provides scrolling and selection.
- *
- * Copyright (c) 1990-1994 The Regents of the University of California.
- * Copyright (c) 1994-1997 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution
- * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- *
- * RCS: @(#) $Id: tkListbox.c,v 1.29.2.5 2007/04/29 02:24:02 das Exp $
- */
- #include "tkPort.h"
- #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 definining configuration
- * options available for listbox
- * items */
- } ListboxOptionTables;
- /*
- * A data structure of the following type is kept for each listbox
- * widget managed by this file:
- */
- typedef struct {
- Tk_Window tkwin; /* Window that embodies the listbox. NULL
- * means that the window has been destroyed
- * but the data structures haven't yet been
- * cleaned up.*/
- Display *display; /* Display containing widget. Used, among
- * other things, so that resources can be
- * freed even after tkwin has gone away. */
- Tcl_Interp *interp; /* Interpreter associated with listbox. */
- Tcl_Command widgetCmd; /* Token for listbox's widget command. */
- Tk_OptionTable optionTable; /* Table that defines configuration options
- * available for this widget. */
- Tk_OptionTable itemAttrOptionTable; /* Table that defines configuration
- * options available for listbox
- * items */
- char *listVarName; /* List variable name */
- Tcl_Obj *listObj; /* Pointer to the list object being used */
- int nElements; /* Holds the current count of elements */
- Tcl_HashTable *selection; /* Tracks selection */
- Tcl_HashTable *itemAttrTable; /* Tracks item attributes */
- /*
- * Information used when displaying widget:
- */
- Tk_3DBorder normalBorder; /* Used for drawing border around whole
- * window, plus used for background. */
- int borderWidth; /* Width of 3-D border around window. */
- int relief; /* 3-D effect: TK_RELIEF_RAISED, etc. */
- int highlightWidth; /* Width in pixels of highlight to draw
- * around widget when it has the focus.
- * <= 0 means don't draw a highlight. */
- XColor *highlightBgColorPtr;
- /* Color for drawing traversal highlight
- * area when highlight is off. */
- XColor *highlightColorPtr; /* Color for drawing traversal highlight. */
- int inset; /* Total width of all borders, including
- * traversal highlight and 3-D border.
- * Indicates how much interior stuff must
- * be offset from outside edges to leave
- * room for borders. */
- Tk_Font tkfont; /* Information about text font, or NULL. */
- XColor *fgColorPtr; /* Text color in normal mode. */
- 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 fit are completely
- * visible in window. There may be one
- * additional line at the bottom that is
- * partially visible. */
- int partialLine; /* 0 means that the window holds exactly
- * fullLines lines. 1 means that there is
- * one additional line that is partially
- * visble. */
- int setGrid; /* Non-zero means pass gridding information
- * to window manager. */
- /*
- * Information to support horizontal scrolling:
- */
- int maxWidth; /* Width (in pixels) of widest string in
- * listbox. */
- int xScrollUnit; /* Number of pixels in one "unit" for
- * horizontal scrolling (window scrolls
- * horizontally in increments of this size).
- * This is an average character size. */
- int xOffset; /* The left edge of each string in the
- * listbox is offset to the left by this
- * many pixels (0 means no offset, positive
- * means there is an offset). */
- /*
- * Information about what's selected or active, if any.
- */
- Tk_Uid selectMode; /* Selection style: single, browse, multiple,
- * or extended. This value isn't used in C
- * code, but the Tcl bindings use it. */
- int numSelected; /* Number of elements currently selected. */
- int selectAnchor; /* Fixed end of selection (i.e. element
- * at which selection was started.) */
- int exportSelection; /* Non-zero means tie internal listbox
- * to X selection. */
- int active; /* Index of "active" element (the one that
- * has been selected by keyboard traversal).
- * -1 means none. */
- 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. */
- } Listbox;
- /*
- * ItemAttr structures are used to store item configuration information for
- * the items in a listbox
- */
- typedef struct {
- Tk_3DBorder border; /* Used for drawing background around text */
- Tk_3DBorder selBorder; /* Used for selected text */
- XColor *fgColor; /* Text color in normal mode. */
- XColor *selFgColor; /* Text color in selected mode. */
- } ItemAttr;
- /*
- * Flag bits for listboxes:
- *
- * REDRAW_PENDING: Non-zero means a DoWhenIdle handler
- * has already been queued to redraw
- * this window.
- * UPDATE_V_SCROLLBAR: Non-zero means vertical scrollbar needs
- * to be updated.
- * UPDATE_H_SCROLLBAR: Non-zero means horizontal scrollbar needs
- * to be updated.
- * GOT_FOCUS: Non-zero means this widget currently
- * has the input focus.
- * MAXWIDTH_IS_STALE: Stored maxWidth may be out-of-date
- * LISTBOX_DELETED: This listbox has been effectively destroyed.
- */
- #define REDRAW_PENDING 1
- #define UPDATE_V_SCROLLBAR 2
- #define UPDATE_H_SCROLLBAR 4
- #define GOT_FOCUS 8
- #define MAXWIDTH_IS_STALE 16
- #define LISTBOX_DELETED 32
- /*
- * The following enum is used to define a type for the -state option
- * of the Entry widget. These values are used as indices into the
- * string table below.
- */
- enum state {
- STATE_DISABLED, STATE_NORMAL
- };
- static char *stateStrings[] = {
- "disabled", "normal", (char *) NULL
- };
- enum activeStyle {
- ACTIVE_STYLE_DOTBOX, ACTIVE_STYLE_NONE, ACTIVE_STYLE_UNDERLINE
- };
- static char *activeStyleStrings[] = {
- "dotbox", "none", "underline", (char *) NULL
- };
- /*
- * The optionSpecs table defines the valid configuration options for the
- * listbox widget
- */
- static Tk_OptionSpec optionSpecs[] = {
- {TK_OPTION_STRING_TABLE, "-activestyle", "activeStyle", "ActiveStyle",
- DEF_LISTBOX_ACTIVE_STYLE, -1, Tk_Offset(Listbox, activeStyle),
- 0, (ClientData) activeStyleStrings, 0},
- {TK_OPTION_BORDER, "-background", "background", "Background",
- DEF_LISTBOX_BG_COLOR, -1, Tk_Offset(Listbox, normalBorder),
- 0, (ClientData) DEF_LISTBOX_BG_MONO, 0},
- {TK_OPTION_SYNONYM, "-bd", (char *) NULL, (char *) NULL,
- (char *) NULL, 0, -1, 0, (ClientData) "-borderwidth", 0},
- {TK_OPTION_SYNONYM, "-bg", (char *) NULL, (char *) NULL,
- (char *) NULL, 0, -1, 0, (ClientData) "-background", 0},
- {TK_OPTION_PIXELS, "-borderwidth", "borderWidth", "BorderWidth",
- DEF_LISTBOX_BORDER_WIDTH, -1, Tk_Offset(Listbox, borderWidth),
- 0, 0, 0},
- {TK_OPTION_CURSOR, "-cursor", "cursor", "Cursor",
- DEF_LISTBOX_CURSOR, -1, Tk_Offset(Listbox, cursor),
- TK_OPTION_NULL_OK, 0, 0},
- {TK_OPTION_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", (char *) NULL,
- (char *) NULL, 0, -1, 0, (ClientData) "-foreground", 0},
- {TK_OPTION_FONT, "-font", "font", "Font",
- DEF_LISTBOX_FONT, -1, Tk_Offset(Listbox, tkfont), 0, 0, 0},
- {TK_OPTION_COLOR, "-foreground", "foreground", "Foreground",
- DEF_LISTBOX_FG, -1, Tk_Offset(Listbox, fgColorPtr), 0, 0, 0},
- {TK_OPTION_INT, "-height", "height", "Height",
- DEF_LISTBOX_HEIGHT, -1, Tk_Offset(Listbox, height), 0, 0, 0},
- {TK_OPTION_COLOR, "-highlightbackground", "highlightBackground",
- "HighlightBackground", DEF_LISTBOX_HIGHLIGHT_BG, -1,
- Tk_Offset(Listbox, highlightBgColorPtr), 0, 0, 0},
- {TK_OPTION_COLOR, "-highlightcolor", "highlightColor", "HighlightColor",
- DEF_LISTBOX_HIGHLIGHT, -1, Tk_Offset(Listbox, highlightColorPtr),
- 0, 0, 0},
- {TK_OPTION_PIXELS, "-highlightthickness", "highlightThickness",
- "HighlightThickness", DEF_LISTBOX_HIGHLIGHT_WIDTH, -1,
- Tk_Offset(Listbox, highlightWidth), 0, 0, 0},
- {TK_OPTION_RELIEF, "-relief", "relief", "Relief",
- DEF_LISTBOX_RELIEF, -1, Tk_Offset(Listbox, relief), 0, 0, 0},
- {TK_OPTION_BORDER, "-selectbackground", "selectBackground", "Foreground",
- DEF_LISTBOX_SELECT_COLOR, -1, Tk_Offset(Listbox, selBorder),
- 0, (ClientData) DEF_LISTBOX_SELECT_MONO, 0},
- {TK_OPTION_PIXELS, "-selectborderwidth", "selectBorderWidth",
- "BorderWidth", DEF_LISTBOX_SELECT_BD, -1,
- Tk_Offset(Listbox, selBorderWidth), 0, 0, 0},
- {TK_OPTION_COLOR, "-selectforeground", "selectForeground", "Background",
- DEF_LISTBOX_SELECT_FG_COLOR, -1, Tk_Offset(Listbox, selFgColorPtr),
- TK_CONFIG_NULL_OK, (ClientData) DEF_LISTBOX_SELECT_FG_MONO, 0},
- {TK_OPTION_STRING, "-selectmode", "selectMode", "SelectMode",
- DEF_LISTBOX_SELECT_MODE, -1, Tk_Offset(Listbox, selectMode),
- TK_OPTION_NULL_OK, 0, 0},
- {TK_OPTION_BOOLEAN, "-setgrid", "setGrid", "SetGrid",
- DEF_LISTBOX_SET_GRID, -1, Tk_Offset(Listbox, setGrid), 0, 0, 0},
- {TK_OPTION_STRING_TABLE, "-state", "state", "State",
- DEF_LISTBOX_STATE, -1, Tk_Offset(Listbox, state),
- 0, (ClientData) 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, (char *) NULL, (char *) NULL, (char *) NULL,
- (char *) NULL, 0, -1, 0, 0, 0}
- };
- /*
- * The itemAttrOptionSpecs table defines the valid configuration options for
- * listbox items
- */
- static Tk_OptionSpec itemAttrOptionSpecs[] = {
- {TK_OPTION_BORDER, "-background", "background", "Background",
- (char *)NULL, -1, Tk_Offset(ItemAttr, border),
- TK_OPTION_NULL_OK|TK_OPTION_DONT_SET_DEFAULT,
- (ClientData) DEF_LISTBOX_BG_MONO, 0},
- {TK_OPTION_SYNONYM, "-bg", (char *) NULL, (char *) NULL,
- (char *) NULL, 0, -1, 0, (ClientData) "-background", 0},
- {TK_OPTION_SYNONYM, "-fg", "foreground", (char *) NULL,
- (char *) NULL, 0, -1, 0, (ClientData) "-foreground", 0},
- {TK_OPTION_COLOR, "-foreground", "foreground", "Foreground",
- (char *) NULL, -1, Tk_Offset(ItemAttr, fgColor),
- TK_OPTION_NULL_OK|TK_OPTION_DONT_SET_DEFAULT, 0, 0},
- {TK_OPTION_BORDER, "-selectbackground", "selectBackground", "Foreground",
- (char *) NULL, -1, Tk_Offset(ItemAttr, selBorder),
- TK_OPTION_NULL_OK|TK_OPTION_DONT_SET_DEFAULT,
- (ClientData) DEF_LISTBOX_SELECT_MONO, 0},
- {TK_OPTION_COLOR, "-selectforeground", "selectForeground", "Background",
- (char *) NULL, -1, Tk_Offset(ItemAttr, selFgColor),
- TK_OPTION_NULL_OK|TK_OPTION_DONT_SET_DEFAULT,
- (ClientData) DEF_LISTBOX_SELECT_FG_MONO, 0},
- {TK_OPTION_END, (char *) NULL, (char *) NULL, (char *) NULL,
- (char *) NULL, 0, -1, 0, 0, 0}
- };
- /*
- * The following tables define the listbox widget commands (and sub-
- * commands) and map the indexes into the string tables into
- * enumerated types used to dispatch the listbox widget command.
- */
- static CONST char *commandNames[] = {
- "activate", "bbox", "cget", "configure", "curselection", "delete", "get",
- "index", "insert", "itemcget", "itemconfigure", "nearest", "scan",
- "see", "selection", "size", "xview", "yview",
- (char *) NULL
- };
- enum command {
- COMMAND_ACTIVATE, COMMAND_BBOX, COMMAND_CGET, COMMAND_CONFIGURE,
- COMMAND_CURSELECTION, COMMAND_DELETE, COMMAND_GET, COMMAND_INDEX,
- COMMAND_INSERT, COMMAND_ITEMCGET, COMMAND_ITEMCONFIGURE,
- COMMAND_NEAREST, COMMAND_SCAN, COMMAND_SEE, COMMAND_SELECTION,
- COMMAND_SIZE, COMMAND_XVIEW, COMMAND_YVIEW
- };
- static CONST char *selCommandNames[] = {
- "anchor", "clear", "includes", "set", (char *) NULL
- };
- enum selcommand {
- SELECTION_ANCHOR, SELECTION_CLEAR, SELECTION_INCLUDES, SELECTION_SET
- };
- static CONST char *scanCommandNames[] = {
- "mark", "dragto", (char *) NULL
- };
- enum scancommand {
- SCAN_MARK, SCAN_DRAGTO
- };
- static CONST char *indexNames[] = {
- "active", "anchor", "end", (char *)NULL
- };
- enum indices {
- INDEX_ACTIVE, INDEX_ANCHOR, INDEX_END
- };
- /* Declarations for procedures defined later in this file */
- static void ChangeListboxOffset _ANSI_ARGS_((Listbox *listPtr,
- int offset));
- static void ChangeListboxView _ANSI_ARGS_((Listbox *listPtr,
- int index));
- static int ConfigureListbox _ANSI_ARGS_((Tcl_Interp *interp,
- Listbox *listPtr, int objc, Tcl_Obj *CONST objv[],
- int flags));
- static int ConfigureListboxItem _ANSI_ARGS_ ((Tcl_Interp *interp,
- Listbox *listPtr, ItemAttr *attrs, int objc,
- Tcl_Obj *CONST objv[], int index));
- static int ListboxDeleteSubCmd _ANSI_ARGS_((Listbox *listPtr,
- int first, int last));
- static void DestroyListbox _ANSI_ARGS_((char *memPtr));
- static void DestroyListboxOptionTables _ANSI_ARGS_ (
- (ClientData clientData, Tcl_Interp *interp));
- static void DisplayListbox _ANSI_ARGS_((ClientData clientData));
- static int GetListboxIndex _ANSI_ARGS_((Tcl_Interp *interp,
- Listbox *listPtr, Tcl_Obj *index, int endIsSize,
- int *indexPtr));
- static int ListboxInsertSubCmd _ANSI_ARGS_((Listbox *listPtr,
- int index, int objc, Tcl_Obj *CONST objv[]));
- static void ListboxCmdDeletedProc _ANSI_ARGS_((
- ClientData clientData));
- static void ListboxComputeGeometry _ANSI_ARGS_((Listbox *listPtr,
- int fontChanged, int maxIsStale, int updateGrid));
- static void ListboxEventProc _ANSI_ARGS_((ClientData clientData,
- XEvent *eventPtr));
- static int ListboxFetchSelection _ANSI_ARGS_((
- ClientData clientData, int offset, char *buffer,
- int maxBytes));
- static void ListboxLostSelection _ANSI_ARGS_((
- ClientData clientData));
- static void EventuallyRedrawRange _ANSI_ARGS_((Listbox *listPtr,
- int first, int last));
- static void ListboxScanTo _ANSI_ARGS_((Listbox *listPtr,
- int x, int y));
- static int ListboxSelect _ANSI_ARGS_((Listbox *listPtr,
- int first, int last, int select));
- static void ListboxUpdateHScrollbar _ANSI_ARGS_(
- (Listbox *listPtr));
- static void ListboxUpdateVScrollbar _ANSI_ARGS_(
- (Listbox *listPtr));
- static int ListboxWidgetObjCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[]));
- static int ListboxBboxSubCmd _ANSI_ARGS_ ((Tcl_Interp *interp,
- Listbox *listPtr, int index));
- static int ListboxSelectionSubCmd _ANSI_ARGS_ (
- (Tcl_Interp *interp, Listbox *listPtr, int objc,
- Tcl_Obj *CONST objv[]));
- static int ListboxXviewSubCmd _ANSI_ARGS_ ((Tcl_Interp *interp,
- Listbox *listPtr, int objc,
- Tcl_Obj *CONST objv[]));
- static int ListboxYviewSubCmd _ANSI_ARGS_ ((Tcl_Interp *interp,
- Listbox *listPtr, int objc,
- Tcl_Obj *CONST objv[]));
- static ItemAttr * ListboxGetItemAttributes _ANSI_ARGS_ (
- (Tcl_Interp *interp, Listbox *listPtr, int index));
- static void ListboxWorldChanged _ANSI_ARGS_((
- ClientData instanceData));
- static int NearestListboxElement _ANSI_ARGS_((Listbox *listPtr,
- int y));
- static char * ListboxListVarProc _ANSI_ARGS_ ((ClientData clientData,
- Tcl_Interp *interp, CONST char *name1,
- CONST char *name2, int flags));
- static void MigrateHashEntries _ANSI_ARGS_ ((Tcl_HashTable *table,
- int first, int last, int offset));
- /*
- * The structure below defines button class behavior by means of procedures
- * that can be invoked from generic window code.
- */
- static Tk_ClassProcs listboxClass = {
- sizeof(Tk_ClassProcs), /* size */
- ListboxWorldChanged, /* worldChangedProc */
- };
- /*
- *--------------------------------------------------------------
- *
- * Tk_ListboxObjCmd --
- *
- * This procedure is invoked to process the "listbox" Tcl
- * command. See the user documentation for details on what
- * it does.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See the user documentation.
- *
- *--------------------------------------------------------------
- */
- int
- Tk_ListboxObjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* 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 ?options?");
- return TCL_ERROR;
- }
- tkwin = Tk_CreateWindowFromPath(interp, Tk_MainWindow(interp),
- Tcl_GetString(objv[1]), (char *) NULL);
- if (tkwin == NULL) {
- return TCL_ERROR;
- }
- optionTables = (ListboxOptionTables *)
- 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 = (ListboxOptionTables *)
- ckalloc(sizeof(ListboxOptionTables));
- /* Set up an exit handler to free the optionTables struct */
- Tcl_SetAssocData(interp, "ListboxOptionTables",
- DestroyListboxOptionTables, (ClientData) optionTables);
- /* Create the listbox option table and the listbox item option table */
- optionTables->listboxOptionTable =
- Tk_CreateOptionTable(interp, optionSpecs);
- optionTables->itemAttrOptionTable =
- Tk_CreateOptionTable(interp, itemAttrOptionSpecs);
- }
- /*
- * Initialize the fields of the structure that won't be initialized
- * by ConfigureListbox, or that ConfigureListbox requires to be
- * initialized already (e.g. resource pointers).
- */
- listPtr = (Listbox *) ckalloc(sizeof(Listbox));
- memset((void *) 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,
- (ClientData) listPtr, ListboxCmdDeletedProc);
- listPtr->optionTable = optionTables->listboxOptionTable;
- listPtr->itemAttrOptionTable = optionTables->itemAttrOptionTable;
- listPtr->selection =
- (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
- Tcl_InitHashTable(listPtr->selection, TCL_ONE_WORD_KEYS);
- listPtr->itemAttrTable =
- (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
- Tcl_InitHashTable(listPtr->itemAttrTable, TCL_ONE_WORD_KEYS);
- listPtr->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;
- /*
- * Keep a hold of the associated tkwin until we destroy the listbox,
- * otherwise Tk might free it while we still need it.
- */
- Tcl_Preserve((ClientData) listPtr->tkwin);
- Tk_SetClass(listPtr->tkwin, "Listbox");
- Tk_SetClassProcs(listPtr->tkwin, &listboxClass, (ClientData) listPtr);
- Tk_CreateEventHandler(listPtr->tkwin,
- ExposureMask|StructureNotifyMask|FocusChangeMask,
- ListboxEventProc, (ClientData) listPtr);
- Tk_CreateSelHandler(listPtr->tkwin, XA_PRIMARY, XA_STRING,
- ListboxFetchSelection, (ClientData) listPtr, XA_STRING);
- if (Tk_InitOptions(interp, (char *)listPtr,
- optionTables->listboxOptionTable, tkwin) != TCL_OK) {
- Tk_DestroyWindow(listPtr->tkwin);
- return TCL_ERROR;
- }
- if (ConfigureListbox(interp, listPtr, objc-2, objv+2, 0) != TCL_OK) {
- Tk_DestroyWindow(listPtr->tkwin);
- return TCL_ERROR;
- }
- Tcl_SetResult(interp, Tk_PathName(listPtr->tkwin), TCL_STATIC);
- return TCL_OK;
- }
- /*
- *----------------------------------------------------------------------
- *
- * ListboxWidgetObjCmd --
- *
- * This Tcl_Obj based procedure is invoked to process the Tcl command
- * that corresponds to a widget managed by this module. See the user
- * documentation for details on what it does.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See the user documentation.
- *
- *----------------------------------------------------------------------
- */
- static int
- ListboxWidgetObjCmd(clientData, interp, objc, objv)
- ClientData clientData; /* Information about listbox widget. */
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments. */
- Tcl_Obj *CONST objv[]; /* Arguments as Tcl_Obj's. */
- {
- register Listbox *listPtr = (Listbox *) clientData;
- int cmdIndex, index;
- int result = TCL_OK;
-
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
- return TCL_ERROR;
- }
- /*
- * 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((ClientData)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: {
- Tcl_Obj *objPtr;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "option");
- result = TCL_ERROR;
- break;
- }
- objPtr = Tk_GetOptionValue(interp, (char *)listPtr,
- listPtr->optionTable, objv[2], listPtr->tkwin);
- if (objPtr == NULL) {
- result = TCL_ERROR;
- break;
- }
- Tcl_SetObjResult(interp, objPtr);
- result = TCL_OK;
- break;
- }
-
- case COMMAND_CONFIGURE: {
- Tcl_Obj *objPtr;
- if (objc <= 3) {
- objPtr = Tk_GetOptionInfo(interp, (char *) listPtr,
- listPtr->optionTable,
- (objc == 3) ? objv[2] : (Tcl_Obj *) NULL,
- listPtr->tkwin);
- if (objPtr == NULL) {
- result = TCL_ERROR;
- break;
- } else {
- Tcl_SetObjResult(interp, objPtr);
- result = TCL_OK;
- }
- } else {
- result = ConfigureListbox(interp, listPtr, objc-2, objv+2, 0);
- }
- break;
- }
- case COMMAND_CURSELECTION: {
- char indexStringRep[TCL_INTEGER_SPACE];
- int i;
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- result = TCL_ERROR;
- break;
- }
- /*
- * Of course, it would be more efficient to use the Tcl_HashTable
- * search functions (Tcl_FirstHashEntry, Tcl_NextHashEntry), but
- * then the result wouldn't be in sorted order. So instead we
- * loop through the indices in order, adding them to the result
- * if they are selected
- */
- for (i = 0; i < listPtr->nElements; i++) {
- if (Tcl_FindHashEntry(listPtr->selection, (char *)i) != NULL) {
- sprintf(indexStringRep, "%d", i);
- Tcl_AppendElement(interp, indexStringRep);
- }
- }
- result = TCL_OK;
- break;
- }
-
- case COMMAND_DELETE: {
- int first, last;
- if ((objc < 3) || (objc > 4)) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "firstIndex ?lastIndex?");
- result = TCL_ERROR;
- break;
- }
- result = GetListboxIndex(interp, listPtr, objv[2], 0, &first);
- if (result != TCL_OK) {
- break;
- }
- if (!(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;
- Tcl_Obj **elemPtrs;
- int listLen;
- if (objc != 3 && objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "firstIndex ?lastIndex?");
- result = TCL_ERROR;
- break;
- }
- result = GetListboxIndex(interp, listPtr, objv[2], 0, &first);
- if (result != TCL_OK) {
- break;
- }
- last = first;
- if (objc == 4) {
- result = GetListboxIndex(interp, listPtr, objv[3], 0, &last);
- if (result != TCL_OK) {
- break;
- }
- }
- if (first >= listPtr->nElements) {
- result = TCL_OK;
- break;
- }
- if (last >= listPtr->nElements) {
- last = listPtr->nElements - 1;
- }
- if (first < 0) {
- first = 0;
- }
- if (first > last) {
- result = TCL_OK;
- break;
- }
- result = Tcl_ListObjGetElements(interp, listPtr->listObj, &listLen,
- &elemPtrs);
- if (result != TCL_OK) {
- break;
- }
- if (objc == 3) {
- /*
- * One element request - we return a string
- */
- Tcl_SetObjResult(interp, elemPtrs[first]);
- } else {
- Tcl_SetListObj(Tcl_GetObjResult(interp), (last - first + 1),
- &(elemPtrs[first]));
- }
- result = TCL_OK;
- break;
- }
- case COMMAND_INDEX:{
- char buf[TCL_INTEGER_SPACE];
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "index");
- result = TCL_ERROR;
- break;
- }
- result = GetListboxIndex(interp, listPtr, objv[2], 1, &index);
- if (result != TCL_OK) {
- break;
- }
- sprintf(buf, "%d", index);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- result = TCL_OK;
- break;
- }
- case COMMAND_INSERT: {
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "index ?element element ...?");
- result = TCL_ERROR;
- break;
- }
- result = GetListboxIndex(interp, listPtr, objv[2], 1, &index);
- if (result != TCL_OK) {
- break;
- }
- if (!(listPtr->state & STATE_NORMAL)) {
- break;
- }
- result = ListboxInsertSubCmd(listPtr, index, objc-3, objv+3);
- break;
- }
- case COMMAND_ITEMCGET: {
- Tcl_Obj *objPtr;
- ItemAttr *attrPtr;
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 2, objv, "index option");
- result = TCL_ERROR;
- break;
- }
- result = GetListboxIndex(interp, listPtr, objv[2], 0, &index);
- if (result != TCL_OK) {
- break;
- }
- if (index < 0 || index >= listPtr->nElements) {
- Tcl_AppendResult(interp, "item number "",
- Tcl_GetString(objv[2]), "" out of range",
- (char *)NULL);
- result = TCL_ERROR;
- break;
- }
-
- attrPtr = ListboxGetItemAttributes(interp, listPtr, index);
- objPtr = Tk_GetOptionValue(interp, (char *)attrPtr,
- listPtr->itemAttrOptionTable, objv[3], listPtr->tkwin);
- if (objPtr == NULL) {
- result = TCL_ERROR;
- break;
- }
- Tcl_SetObjResult(interp, objPtr);
- result = TCL_OK;
- break;
- }
- case COMMAND_ITEMCONFIGURE: {
- Tcl_Obj *objPtr;
- ItemAttr *attrPtr;
- if (objc < 3) {
- Tcl_WrongNumArgs(interp, 2, objv,
- "index ?option? ?value? ?option value ...?");
- result = TCL_ERROR;
- break;
- }
- result = GetListboxIndex(interp, listPtr, objv[2], 0, &index);
- if (result != TCL_OK) {
- break;
- }
-
- if (index < 0 || index >= listPtr->nElements) {
- Tcl_AppendResult(interp, "item number "",
- Tcl_GetString(objv[2]), "" out of range",
- (char *)NULL);
- result = TCL_ERROR;
- break;
- }
-
- attrPtr = ListboxGetItemAttributes(interp, listPtr, index);
- if (objc <= 4) {
- objPtr = Tk_GetOptionInfo(interp, (char *)attrPtr,
- listPtr->itemAttrOptionTable,
- (objc == 4) ? objv[3] : (Tcl_Obj *) NULL,
- listPtr->tkwin);
- if (objPtr == NULL) {
- result = TCL_ERROR;
- break;
- } else {
- Tcl_SetObjResult(interp, objPtr);
- result = TCL_OK;
- }
- } else {
- result = ConfigureListboxItem(interp, listPtr, attrPtr,
- objc-3, objv+3, index);
- }
- break;
- }
-
- case COMMAND_NEAREST: {
- char buf[TCL_INTEGER_SPACE];
- int y;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "y");
- result = TCL_ERROR;
- break;
- }
-
- result = Tcl_GetIntFromObj(interp, objv[2], &y);
- if (result != TCL_OK) {
- break;
- }
- index = NearestListboxElement(listPtr, y);
- sprintf(buf, "%d", index);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- result = TCL_OK;
- break;
- }
-
- case COMMAND_SCAN: {
- int x, y, scanCmdIndex;
- if (objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "mark|dragto x y");
- result = TCL_ERROR;
- break;
- }
- if (Tcl_GetIntFromObj(interp, objv[3], &x) != TCL_OK
- || Tcl_GetIntFromObj(interp, objv[4], &y) != TCL_OK) {
- result = TCL_ERROR;
- break;
- }
- result = Tcl_GetIndexFromObj(interp, objv[2], scanCommandNames,
- "option", 0, &scanCmdIndex);
- if (result != TCL_OK) {
- break;
- }
- switch (scanCmdIndex) {
- case SCAN_MARK: {
- listPtr->scanMarkX = x;
- listPtr->scanMarkY = y;
- listPtr->scanMarkXOffset = listPtr->xOffset;
- listPtr->scanMarkYIndex = listPtr->topIndex;
- break;
- }
- case SCAN_DRAGTO: {
- ListboxScanTo(listPtr, x, y);
- break;
- }
- }
- result = TCL_OK;
- break;
- }
- case COMMAND_SEE: {
- int diff;
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "index");
- result = TCL_ERROR;
- break;
- }
- result = GetListboxIndex(interp, listPtr, objv[2], 0, &index);
- if (result != TCL_OK) {
- break;
- }
- if (index >= listPtr->nElements) {
- index = listPtr->nElements - 1;
- }
- if (index < 0) {
- index = 0;
- }
- diff = listPtr->topIndex - index;
- if (diff > 0) {
- if (diff <= (listPtr->fullLines/3)) {
- ChangeListboxView(listPtr, index);
- } else {
- ChangeListboxView(listPtr,
- index - (listPtr->fullLines-1)/2);
- }
- } else {
- diff = index - (listPtr->topIndex + listPtr->fullLines - 1);
- if (diff > 0) {
- if (diff <= (listPtr->fullLines/3)) {
- ChangeListboxView(listPtr, listPtr->topIndex + diff);
- } else {
- ChangeListboxView(listPtr,
- index - (listPtr->fullLines-1)/2);
- }
- }
- }
- result = TCL_OK;
- break;
- }
- case COMMAND_SELECTION: {
- result = ListboxSelectionSubCmd(interp, listPtr, objc, objv);
- break;
- }
- case COMMAND_SIZE: {
- char buf[TCL_INTEGER_SPACE];
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
- result = TCL_ERROR;
- break;
- }
- sprintf(buf, "%d", listPtr->nElements);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- result = TCL_OK;
- break;
- }
- case COMMAND_XVIEW: {
- result = ListboxXviewSubCmd(interp, listPtr, objc, objv);
- break;
- }
-
- case COMMAND_YVIEW: {
- result = ListboxYviewSubCmd(interp, listPtr, objc, objv);
- break;
- }
- }
- Tcl_Release((ClientData)listPtr);
- return result;
- }
- /*
- *----------------------------------------------------------------------
- *
- * ListboxBboxSubCmd --
- *
- * This procedure is invoked to process a listbox bbox request.
- * See the user documentation for more information.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * For valid indices, places the bbox of the requested element in
- * the interpreter's result.
- *
- *----------------------------------------------------------------------
- */
- static int
- ListboxBboxSubCmd(interp, listPtr, index)
- Tcl_Interp *interp; /* Pointer to the calling Tcl interpreter */
- Listbox *listPtr; /* Information about the listbox */
- int index; /* Index of the element to get bbox info on */
- {
- int lastVisibleIndex;
- /* Determine the index of the last visible item in the listbox */
- lastVisibleIndex = listPtr->topIndex + listPtr->fullLines
- + listPtr->partialLine;
- if (listPtr->nElements < lastVisibleIndex) {
- lastVisibleIndex = listPtr->nElements;
- }
- /* Only allow bbox requests for indices that are visible */
- if ((listPtr->topIndex <= index) && (index < lastVisibleIndex)) {
- char buf[TCL_INTEGER_SPACE * 4];
- Tcl_Obj *el;
- char *stringRep;
- int pixelWidth, stringLen, x, y, result;
- Tk_FontMetrics fm;
- /* Compute the pixel width of the requested element */
- result = Tcl_ListObjIndex(interp, listPtr->listObj, index, &el);
- if (result != TCL_OK) {
- return result;
- }
- stringRep = Tcl_GetStringFromObj(el, &stringLen);
- Tk_GetFontMetrics(listPtr->tkfont, &fm);
- pixelWidth = Tk_TextWidth(listPtr->tkfont, stringRep, stringLen);
- x = listPtr->inset + listPtr->selBorderWidth - listPtr->xOffset;
- y = ((index - listPtr->topIndex)*listPtr->lineHeight)
- + listPtr->inset + listPtr->selBorderWidth;
- sprintf(buf, "%d %d %d %d", x, y, pixelWidth, fm.linespace);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- }
- return TCL_OK;
- }
- /*
- *----------------------------------------------------------------------
- *
- * ListboxSelectionSubCmd --
- *
- * This procedure is invoked to process the selection sub command
- * for listbox widgets.
- *
- * Results:
- * Standard Tcl result.
- *
- * Side effects:
- * May set the interpreter's result field.
- *
- *----------------------------------------------------------------------
- */
- static int
- ListboxSelectionSubCmd(interp, listPtr, objc, objv)
- Tcl_Interp *interp; /* Pointer to the calling Tcl interpreter */
- Listbox *listPtr; /* Information about the listbox */
- int objc; /* Number of arguments in the objv array */
- Tcl_Obj *CONST objv[]; /* Array of arguments to the procedure */
- {
- int selCmdIndex, first, last;
- int result = TCL_OK;
- if (objc != 4 && objc != 5) {
- Tcl_WrongNumArgs(interp, 2, objv, "option index ?index?");
- return TCL_ERROR;
- }
- result = GetListboxIndex(interp, listPtr, objv[3], 0, &first);
- if (result != TCL_OK) {
- return result;
- }
- last = first;
- if (objc == 5) {
- result = GetListboxIndex(interp, listPtr, objv[4], 0, &last);
- if (result != TCL_OK) {
- return result;
- }
- }
- result = Tcl_GetIndexFromObj(interp, objv[2], selCommandNames,
- "option", 0, &selCmdIndex);
- if (result != TCL_OK) {
- return result;
- }
- /*
- * 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,
- (char *)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(interp, listPtr, objc, objv)
- Tcl_Interp *interp; /* Pointer to the calling Tcl interpreter */
- Listbox *listPtr; /* Information about the listbox */
- int objc; /* Number of arguments in the objv array */
- Tcl_Obj *CONST objv[]; /* Array of arguments to the procedure */
- {
- int index, count, type, windowWidth, windowUnits;
- int offset = 0; /* Initialized to stop gcc warnings. */
- double fraction, fraction2;
-
- windowWidth = Tk_Width(listPtr->tkwin)
- - 2*(listPtr->inset + listPtr->selBorderWidth);
- if (objc == 2) {
- if (listPtr->maxWidth == 0) {
- Tcl_SetResult(interp, "0 1", TCL_STATIC);
- } else {
- char buf[TCL_DOUBLE_SPACE * 2];
-
- fraction = listPtr->xOffset/((double) listPtr->maxWidth);
- fraction2 = (listPtr->xOffset + windowWidth)
- /((double) listPtr->maxWidth);
- if (fraction2 > 1.0) {
- fraction2 = 1.0;
- }
- sprintf(buf, "%g %g", fraction, fraction2);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- }
- } else if (objc == 3) {
- if (Tcl_GetIntFromObj(interp, objv[2], &index) != TCL_OK) {
- return TCL_ERROR;
- }
- ChangeListboxOffset(listPtr, index*listPtr->xScrollUnit);
- } else {
- type = Tk_GetScrollInfoObj(interp, objc, objv, &fraction, &count);
- switch (type) {
- case TK_SCROLL_ERROR:
- return TCL_ERROR;
- case TK_SCROLL_MOVETO:
- offset = (int) (fraction*listPtr->maxWidth + 0.5);
- break;
- case TK_SCROLL_PAGES:
- windowUnits = windowWidth/listPtr->xScrollUnit;
- if (windowUnits > 2) {
- offset = listPtr->xOffset
- + count*listPtr->xScrollUnit*(windowUnits-2);
- } else {
- offset = listPtr->xOffset + count*listPtr->xScrollUnit;
- }
- break;
- case TK_SCROLL_UNITS:
- offset = listPtr->xOffset + count*listPtr->xScrollUnit;
- break;
- }
- ChangeListboxOffset(listPtr, offset);
- }
- return TCL_OK;
- }
- /*
- *----------------------------------------------------------------------
- *
- * ListboxYviewSubCmd --
- *
- * Process the listbox "yview" subcommand.
- *
- * Results:
- * Standard Tcl result.
- *
- * Side effects:
- * May change the listbox viewing area; may set the interpreter's result.
- *
- *----------------------------------------------------------------------
- */
- static int
- ListboxYviewSubCmd(interp, listPtr, objc, objv)
- Tcl_Interp *interp; /* Pointer to the calling Tcl interpreter */
- Listbox *listPtr; /* Information about the listbox */
- int objc; /* Number of arguments in the objv array */
- Tcl_Obj *CONST objv[]; /* Array of arguments to the procedure */
- {
- int index, count, type;
- double fraction, fraction2;
-
- if (objc == 2) {
- if (listPtr->nElements == 0) {
- Tcl_SetResult(interp, "0 1", TCL_STATIC);
- } else {
- char buf[TCL_DOUBLE_SPACE * 2];
-
- fraction = listPtr->topIndex/((double) listPtr->nElements);
- fraction2 = (listPtr->topIndex+listPtr->fullLines)
- /((double) listPtr->nElements);
- if (fraction2 > 1.0) {
- fraction2 = 1.0;
- }
- sprintf(buf, "%g %g", fraction, fraction2);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- }
- } else if (objc == 3) {
- if (GetListboxIndex(interp, listPtr, objv[2], 0, &index) != TCL_OK) {
- return TCL_ERROR;
- }
- ChangeListboxView(listPtr, index);
- } else {
- type = Tk_GetScrollInfoObj(interp, objc, objv, &fraction, &count);
- switch (type) {
- case TK_SCROLL_ERROR:
- return TCL_ERROR;
- case TK_SCROLL_MOVETO:
- index = (int) (listPtr->nElements*fraction + 0.5);
- break;
- case TK_SCROLL_PAGES:
- if (listPtr->fullLines > 2) {
- index = listPtr->topIndex
- + count*(listPtr->fullLines-2);
- } else {
- index = listPtr->topIndex + count;
- }
- break;
- case TK_SCROLL_UNITS:
- index = listPtr->topIndex + count;
- break;
- }
- ChangeListboxView(listPtr, index);
- }
- return TCL_OK;
- }
- /*
- *----------------------------------------------------------------------
- *
- * ListboxGetItemAttributes --
- *
- * Returns a pointer to the ItemAttr record for a given index,
- * creating one if it does not already exist.
- *
- * Results:
- * Pointer to an ItemAttr record.
- *
- * Side effects:
- * Memory may be allocated for the ItemAttr record.
- *
- *----------------------------------------------------------------------
- */
- static ItemAttr *
- ListboxGetItemAttributes(interp, listPtr, index)
- Tcl_Interp *interp; /* Pointer to the calling Tcl interpreter */
- Listbox *listPtr; /* Information about the listbox */
- int index; /* Index of the item to retrieve attributes
- * for */
- {
- int new;
- Tcl_HashEntry *entry;
- ItemAttr *attrs;
- entry = Tcl_CreateHashEntry(listPtr->itemAttrTable, (char *)index, &new);
- if (new) {
- attrs = (ItemAttr *) ckalloc(sizeof(ItemAttr));
- attrs->border = NULL;
- attrs->selBorder = NULL;
- attrs->fgColor = NULL;
- attrs->selFgColor = NULL;
- Tk_InitOptions(interp, (char *)attrs, listPtr->itemAttrOptionTable,
- listPtr->tkwin);
- Tcl_SetHashValue(entry, (ClientData) attrs);
- }
- attrs = (ItemAttr *)Tcl_GetHashValue(entry);
- return attrs;
- }
- /*
- *----------------------------------------------------------------------
- *
- * DestroyListbox --
- *
- * This procedure is invoked by Tcl_EventuallyFree or Tcl_Release
- * to clean up the internal structure of a listbox at a safe time
- * (when no-one is using it anymore).
- *
- * Results:
- * None.
- *
- * Side effects:
- * Everything associated with the listbox is freed up.
- *
- *----------------------------------------------------------------------
- */
- static void
- DestroyListbox(memPtr)
- char *memPtr; /* Info about listbox widget. */
- {
- register Listbox *listPtr = (Listbox *) memPtr;
- Tcl_HashEntry *entry;
- Tcl_HashSearch search;
- /* If we have an internal list object, free it */
- if (listPtr->listObj != NULL) {
- Tcl_DecrRefCount(listPtr->listObj);
- listPtr->listObj = NULL;
- }
- if (listPtr->listVarName != NULL) {
- Tcl_UntraceVar(listPtr->interp, listPtr->listVarName,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- ListboxListVarProc, (ClientData) listPtr);
- }
-
- /* Free the selection hash table */
- Tcl_DeleteHashTable(listPtr->selection);
- ckfree((char *)listPtr->selection);
- /* Free the item attribute hash table */
- for (entry = Tcl_FirstHashEntry(listPtr->itemAttrTable, &search);
- entry != NULL; entry = Tcl_NextHashEntry(&search)) {
- ckfree((char *)Tcl_GetHashValue(entry));
- }
- Tcl_DeleteHashTable(listPtr->itemAttrTable);
- ckfree((char *)listPtr->itemAttrTable);
- /*
- * Free up all the stuff that requires special handling, then
- * let Tk_FreeOptions handle all the standard option-related
- * stuff.
- */
- if (listPtr->textGC != None) {
- Tk_FreeGC(listPtr->display, listPtr->textGC);
- }
- if (listPtr->selTextGC != None) {
- Tk_FreeGC(listPtr->display, listPtr->selTextGC);
- }
- if (listPtr->gray != None) {
- Tk_FreeBitmap(Tk_Display(listPtr->tkwin), listPtr->gray);
- }
- Tk_FreeConfigOptions((char *)listPtr, listPtr->optionTable,
- listPtr->tkwin);
- Tcl_Release((ClientData) listPtr->tkwin);
- listPtr->tkwin = NULL;
- ckfree((char *) listPtr);
- }
- /*
- *----------------------------------------------------------------------
- *
- * DestroyListboxOptionTables --
- *
- * This procedure is registered as an exit callback when the listbox
- * command is first called. It cleans up the OptionTables structure
- * allocated by that command.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Frees memory.
- *
- *----------------------------------------------------------------------
- */
- static void
- DestroyListboxOptionTables(clientData, interp)
- ClientData clientData; /* Pointer to the OptionTables struct */
- Tcl_Interp *interp; /* Pointer to the calling interp */
- {
- ckfree((char *)clientData);
- return;
- }
- /*
- *----------------------------------------------------------------------
- *
- * ConfigureListbox --
- *
- * This procedure is called to process an objv/objc list, plus
- * the Tk option database, in order to configure (or reconfigure)
- * a listbox widget.
- *
- * Results:
- * The return value is a standard Tcl result. If TCL_ERROR is
- * returned, then the interp's result contains an error message.
- *
- * Side effects:
- * Configuration information, such as colors, border width,
- * etc. get set for listPtr; old resources get freed,
- * if there were any.
- *
- *----------------------------------------------------------------------
- */
- static int
- ConfigureListbox(interp, listPtr, objc, objv, flags)
- Tcl_Interp *interp; /* Used for error reporting. */
- register Listbox *listPtr; /* Information about widget; may or may
- * not already have values for some fields. */
- int objc; /* Number of valid entries in argv. */
- Tcl_Obj *CONST objv[]; /* Arguments. */
- int flags; /* Flags to pass to Tk_ConfigureWidget. */
- {
- Tk_SavedOptions savedOptions;
- Tcl_Obj *oldListObj = NULL;
- Tcl_Obj *errorResult = NULL;
- int oldExport, error;
- oldExport = listPtr->exportSelection;
- if (listPtr->listVarName != NULL) {
- Tcl_UntraceVar(interp, listPtr->listVarName,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- ListboxListVarProc, (ClientData) 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, (int *) 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.
- */
- if (listPtr->exportSelection && !oldExport
- && (listPtr->numSelected != 0)) {
- Tk_OwnSelection(listPtr->tkwin, XA_PRIMARY, ListboxLostSelection,
- (ClientData) listPtr);
- }
- /* Verify the current status of the list var.
- * PREVIOUS STATE | NEW STATE | ACTION
- * ---------------+------------+----------------------------------
- * no listvar | listvar | If listvar does not exist, create
- * it and copy the internal list obj's
- * content to the new var. If it does
- * exist, toss the internal list obj.
- *
- * listvar | no listvar | Copy old listvar content to the
- * internal list obj
- *
- * listvar | listvar | no special action
- *
- * no listvar | no listvar | no special action
- */
- oldListObj = listPtr->listObj;
- if (listPtr->listVarName != NULL) {
- Tcl_Obj *listVarObj = Tcl_GetVar2Ex(interp, listPtr->listVarName,
- (char *) NULL, TCL_GLOBAL_ONLY);
- int dummy;
- if (listVarObj == NULL) {
- listVarObj = (oldListObj ? oldListObj : Tcl_NewObj());
- if (Tcl_SetVar2Ex(interp, listPtr->listVarName, (char *) NULL,
- listVarObj, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG)
- == NULL) {
- if (oldListObj == NULL) {
- Tcl_DecrRefCount(listVarObj);
- }
- 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", (char *) NULL);
- continue;
- }
- listPtr->listObj = listVarObj;
- Tcl_TraceVar(listPtr->interp, listPtr->listVarName,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- ListboxListVarProc, (ClientData) listPtr);
- } else if (listPtr->listObj == NULL) {
- listPtr->listObj = Tcl_NewObj();
- }
- Tcl_IncrRefCount(listPtr->listObj);
- if (oldListObj != NULL) {
- Tcl_DecrRefCount(oldListObj);
- }
- 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;
- } else {
- ListboxWorldChanged((ClientData) listPtr);
- return TCL_OK;
- }
- }
- /*
- *----------------------------------------------------------------------
- *
- * ConfigureListboxItem --
- *
- * This procedure is called to process an objv/objc list, plus
- * the Tk option database, in order to configure (or reconfigure)
- * a listbox item.
- *
- * Results:
- * The return value is a standard Tcl result. If TCL_ERROR is
- * returned, then the interp's result contains an error message.
- *
- * Side effects:
- * Configuration information, such as colors, border width,
- * etc. get set for a listbox item; old resources get freed,
- * if there were any.
- *
- *----------------------------------------------------------------------
- */
- static int
- ConfigureListboxItem(interp, listPtr, attrs, objc, objv, index)
- 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, (int *)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(instanceData)
- ClientData instanceData; /* Information about widget. */
- {
- XGCValues gcValues;
- GC gc;
- unsigned long mask;
- Listbox *listPtr;
-
- listPtr = (Listbox *) 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 clientData; /* Information about window. */
- {
- register Listbox *listPtr = (Listbox *) clientData;
- register Tk_Window tkwin = listPtr->tkwin;
- GC gc;
- int i, limit, x, y, width, prevSelected, freeGC;
- Tk_FontMetrics fm;
- Tcl_Obj *curElement;
- Tcl_HashEntry *entry;
- char *stringRep;
- int stringLen;
- ItemAttr *attrs;
- Tk_3DBorder selectedBg;
- XGCValues gcValues;
- unsigned long mask;
- int left, right; /* Non-zero values here indicate
- * that the left or right edge of
- * the listbox is off-screen. */
- Pixmap pixmap;
- listPtr->flags &= ~REDRAW_PENDING;
- if (listPtr->flags & 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((ClientData) listPtr);
- if (listPtr->flags & UPDATE_V_SCROLLBAR) {
- ListboxUpdateVScrollbar(listPtr);
- if ((listPtr->flags & LISTBOX_DELETED) || !Tk_IsMapped(tkwin)) {
- Tcl_Release((ClientData) listPtr);
- return;
- }
- }
- if (listPtr->flags & UPDATE_H_SCROLLBAR) {
- ListboxUpdateHScrollbar(listPtr);
- if ((listPtr->flags & LISTBOX_DELETED) || !Tk_IsMapped(tkwin)) {
- Tcl_Release((ClientData) listPtr);
- return;
- }
- }
- listPtr->flags &= ~(REDRAW_PENDING|UPDATE_V_SCROLLBAR|UPDATE_H_SCROLLBAR);
- Tcl_Release((ClientData) 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++) {
- 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, (char *)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, (char *)i) != NULL) {
- /* 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 = (ItemAttr *)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,
- (char *)(i + 1)) == NULL ) {
- Tk_3DHorizontalBevel(tkwin, pixmap, selectedBg, x-left,
- y + listPtr->lineHeight - listPtr->selBorderWidth,
- width+left+right, listPtr->selBorderWidth, 0, 0, 0,
- TK_RELIEF_RAISED);
- }
- prevSelected = 1;
- } else {
- /*
- * If there is an item attributes record for this item, draw
- * the background box and set the foreground color accordingly
- */
- if (entry != NULL) {
- attrs = (ItemAttr *)Tcl_GetHashValue(entry);
- gcValues.foreground = listPtr->fgColorPtr->pixel;
- gcValues.font = Tk_FontId(listPtr->tkfont);
- gcValues.graphics_exposures = False;
- mask = GCForeground | GCFont | GCGraphicsExposures;
-
- /*
- * If 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 */
- Tk_GetFontMetrics(listPtr->tkfont, &fm);
- y += fm.ascent + listPtr->selBorderWidth;
- x = listPtr->inset + listPtr->selBorderWidth - listPtr->xOffset;
- Tcl_ListObjIndex(listPtr->interp, listPtr->listObj, i, &curElement);
- stringRep = Tcl_GetStringFromObj(curElement, &stringLen);
- Tk_DrawChars(listPtr->display, pixmap, gc, listPtr->tkfont,
- stringRep, stringLen, x, y);
- /* If this is the active element, 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
- /*
- * 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
- }
- }
- 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(listPtr, fontChanged, maxIsStale, updateGrid)
- Listbox *listPtr; /* Listbox whose geometry is to be
- * recomputed. */
- int fontChanged; /* Non-zero means the font may have changed
- * so per-element width information also
- * has to be computed. */
- int maxIsStale; /* Non-zero means the "maxWidth" field may
- * no longer be up-to-date and must
- * be recomputed. If fontChanged is 1 then
- * this must be 1. */
- int updateGrid; /* Non-zero means call Tk_SetGrid or
- * Tk_UnsetGrid to update gridding for
- * the window. */
- {
- int width, height, pixelWidth, pixelHeight;
- Tk_FontMetrics fm;
- Tcl_Obj *element;
- int textLength;
- char *text;
- int i, result;
-
- if (fontChanged || maxIsStale) {
- listPtr->xScrollUnit = Tk_TextWidth(listPtr->tkfont, "0", 1);
- if (listPtr->xScrollUnit == 0) {
- listPtr->xScrollUnit = 1;
- }
- listPtr->maxWidth = 0;
- for (i = 0; i < listPtr->nElements; i++) {
- /* Compute the pixel width of the current element */
- result = Tcl_ListObjIndex(listPtr->interp, listPtr->listObj, i,
- &element);
- if (result != TCL_OK) {
- continue;
- }
- text = Tcl_GetStringFromObj(element, &textLength);
- Tk_GetFontMetrics(listPtr->tkfont, &fm);
- pixelWidth = Tk_TextWidth(listPtr->tkfont, text, textLength);
- if (pixelWidth > listPtr->maxWidth) {
- listPtr->maxWidth = pixelWidth;
- }
- }
- }
- Tk_GetFontMetrics(listPtr->tkfont, &fm);
- listPtr->lineHeight = fm.linespace + 1 + 2*listPtr->selBorderWidth;
- width = listPtr->width;
- if (width <= 0) {
- width = (listPtr->maxWidth + listPtr->xScrollUnit - 1)
- /listPtr->xScrollUnit;
- if (width < 1) {
- width = 1;
- }
- }
- pixelWidth = width*listPtr->xScrollUnit + 2*listPtr->inset
- + 2*listPtr->selBorderWidth;
- height = listPtr->height;
- if (listPtr->height <= 0) {
- height = listPtr->nElements;
- if (height < 1) {
- height = 1;
- }
- }
- pixelHeight = height*listPtr->lineHeight + 2*listPtr->inset;
- Tk_GeometryRequest(listPtr->tkwin, pixelWidth, pixelHeight);
- Tk_SetInternalBorder(listPtr->tkwin, listPtr->inset);
- if (updateGrid) {
- if (listPtr->setGrid) {
- Tk_SetGrid(listPtr->tkwin, width, height, listPtr->xScrollUnit,
- listPtr->lineHeight);
- } else {
- Tk_UnsetGrid(listPtr->tkwin);
- }
- }
- }
- /*
- *----------------------------------------------------------------------
- *
- * ListboxInsertSubCmd --
- *
- * This procedure is invoked to handle the listbox "insert"
- * subcommand.
- *
- * Results:
- * Standard Tcl result.
- *
- * Side effects:
- * New elements are added to the listbox pointed to by listPtr;
- * a refresh callback is registered for the listbox.
- *
- *----------------------------------------------------------------------
- */
- static int
- ListboxInsertSubCmd(listPtr, index, objc, objv)
- register Listbox *listPtr; /* Listbox that is to get the new
- * elements. */
- int index; /* Add the new elements before this
- * element. */
- int objc; /* Number of new elements to add. */
- Tcl_Obj *CONST objv[]; /* New elements (one per entry). */
- {
- int i, oldMaxWidth;
- Tcl_Obj *newListObj;
- int pixelWidth;
- int result;
- char *stringRep;
- int length;
-
- oldMaxWidth = listPtr->maxWidth;
- for (i = 0; i < objc; i++) {
- /*
- * Check if any of the new elements are wider than the current widest;
- * if so, update our notion of "widest."
- */
- stringRep = Tcl_GetStringFromObj(objv[i], &length);
- pixelWidth = Tk_TextWidth(listPtr->tkfont, stringRep, length);
- if (pixelWidth > listPtr->maxWidth) {
- listPtr->maxWidth = pixelWidth;
- }
- }
-
- /* Adjust selection and attribute information for every index after
- * the first index */
- MigrateHashEntries(listPtr->selection, index, listPtr->nElements-1, objc);
- MigrateHashEntries(listPtr->itemAttrTable, index, listPtr->nElements-1,
- objc);
-
- /* If the object is shared, duplicate it before writing to it */
- if (Tcl_IsShared(listPtr->listObj)) {
- newListObj = Tcl_DuplicateObj(listPtr->listObj);
- } else {
- newListObj = listPtr->listObj;
- }
- result =
- Tcl_ListObjReplace(listPtr->interp, newListObj, index, 0, objc, objv);
- if (result != TCL_OK) {
- return result;
- }
- /*
- * 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,
- (char *) 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(listPtr, first, last)
- register Listbox *listPtr; /* Listbox widget to modify. */
- int first; /* Index of first element to delete. */
- int last; /* Index of last element to delete. */
- {
- int count, i, widthChanged;
- Tcl_Obj *newListObj;
- Tcl_Obj *element;
- int length;
- char *stringRep;
- int result;
- int pixelWidth;
- Tcl_HashEntry *entry;
-
- /*
- * Adjust the range to fit within the existing elements of the
- * listbox, and make sure there's something to delete.
- */
- if (first < 0) {
- first = 0;
- }
- if (last >= listPtr->nElements) {
- last = listPtr->nElements-1;
- }
- count = last + 1 - first;
- if (count <= 0) {
- return TCL_OK;
- }
- /*
- * Foreach deleted index we must:
- * a) remove selection information
- * b) check the width of the element; if it is equal to the max, set
- * widthChanged to 1, because it may be the only element with that
- * width
- */
- widthChanged = 0;
- for (i = first; i <= last; i++) {
- /* Remove selection information */
- entry = Tcl_FindHashEntry(listPtr->selection, (char *)i);
- if (entry != NULL) {
- listPtr->numSelected--;
- Tcl_DeleteHashEntry(entry);
- }
- entry = Tcl_FindHashEntry(listPtr->itemAttrTable, (char *)i);
- if (entry != NULL) {
- ckfree((char *)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,
- (char *) 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, eventPtr)
- ClientData clientData; /* Information about window. */
- XEvent *eventPtr; /* Information about event. */
- {
- Listbox *listPtr = (Listbox *) clientData;
-
- if (eventPtr->type == Expose) {
- EventuallyRedrawRange(listPtr,
- NearestListboxElement(listPtr, eventPtr->xexpose.y),
- NearestListboxElement(listPtr, eventPtr->xexpose.y
- + eventPtr->xexpose.height));
- } else if (eventPtr->type == DestroyNotify) {
- 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, 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 clientData; /* Pointer to widget record for widget. */
- {
- Listbox *listPtr = (Listbox *) clientData;
- /*
- * This procedure could be invoked either because the window was
- * destroyed and the command was then deleted (in which case tkwin
- * is NULL) or because the command was deleted, and then this procedure
- * destroys the widget.
- */
- if (!(listPtr->flags & LISTBOX_DELETED)) {
- Tk_DestroyWindow(listPtr->tkwin);
- }
- }
- /*
- *--------------------------------------------------------------
- *
- * GetListboxIndex --
- *
- * Parse an index into a listbox and return either its value
- * or an error.
- *
- * Results:
- * A standard Tcl result. If all went well, then *indexPtr is
- * filled in with the index (into listPtr) corresponding to
- * string. Otherwise an error message is left in the interp's result.
- *
- * Side effects:
- * None.
- *
- *--------------------------------------------------------------
- */
- static int
- GetListboxIndex(interp, listPtr, indexObj, endIsSize, indexPtr)
- Tcl_Interp *interp; /* For error messages. */
- Listbox *listPtr; /* Listbox for which the index is being
- * specified. */
- Tcl_Obj *indexObj; /* Specifies an element in the listbox. */
- int endIsSize; /* If 1, "end" refers to the number of
- * entries in the listbox. If 0, "end"
- * refers to 1 less than the number of
- * entries. */
- int *indexPtr; /* Where to store converted index. */
- {
- int result;
- int index;
- char *stringRep;
-
- /* First see if the index is one of the named indices */
- result = Tcl_GetIndexFromObj(NULL, indexObj, indexNames, "", 0, &index);
- if (result == TCL_OK) {
- switch (index) {
- case INDEX_ACTIVE: {
- /* "active" index */
- *indexPtr = listPtr->active;
- break;
- }
- case INDEX_ANCHOR: {
- /* "anchor" index */
- *indexPtr = listPtr->selectAnchor;
- break;
- }
- case INDEX_END: {
- /* "end" index */
- if (endIsSize) {
- *indexPtr = listPtr->nElements;
- } else {
- *indexPtr = listPtr->nElements - 1;
- }
- break;
- }
- }
- return TCL_OK;
- }
- /* The index didn't match any of the named indices; maybe it's an @x,y */
- stringRep = Tcl_GetString(indexObj);
- if (stringRep[0] == '@') {
- /* @x,y index */
- int y;
- char *start, *end;
- start = stringRep + 1;
- strtol(start, &end, 0);
- if ((start == end) || (*end != ',')) {
- Tcl_AppendResult(interp, "bad listbox index "", stringRep,
- "": must be active, anchor, end, @x,y, or a number",
- (char *)NULL);
- return TCL_ERROR;
- }
- start = end+1;
- y = strtol(start, &end, 0);
- if ((start == end) || (*end != ' ')) {
- Tcl_AppendResult(interp, "bad listbox index "", stringRep,
- "": must be active, anchor, end, @x,y, or a number",
- (char *)NULL);
- return TCL_ERROR;
- }
- *indexPtr = NearestListboxElement(listPtr, y);
- return TCL_OK;
- }
-
- /* Maybe the index is just an integer */
- if (Tcl_GetIntFromObj(interp, indexObj, indexPtr) == TCL_OK) {
- return TCL_OK;
- }
- /* Everything failed, nothing matched. Throw up an error message */
- Tcl_ResetResult(interp);
- Tcl_AppendResult(interp, "bad listbox index "",
- Tcl_GetString(indexObj), "": must be active, anchor, ",
- "end, @x,y, or a number", (char *) NULL);
- return TCL_ERROR;
- }
- /*
- *----------------------------------------------------------------------
- *
- * ChangeListboxView --
- *
- * Change the view on a listbox widget so that a given element
- * is displayed at the top.
- *
- * Results:
- * None.
- *
- * Side effects:
- * What's displayed on the screen is changed. If there is a
- * scrollbar associated with this widget, then the scrollbar
- * is instructed to change its display too.
- *
- *----------------------------------------------------------------------
- */
- static void
- ChangeListboxView(listPtr, index)
- register Listbox *listPtr; /* Information about widget. */
- int index; /* Index of element in listPtr
- * that should now appear at the
- * top of the listbox. */
- {
- if (index >= (listPtr->nElements - listPtr->fullLines)) {
- index = listPtr->nElements - listPtr->fullLines;
- }
- if (index < 0) {
- index = 0;
- }
- if (listPtr->topIndex != index) {
- listPtr->topIndex = index;
- EventuallyRedrawRange(listPtr, 0, listPtr->nElements-1);
- listPtr->flags |= UPDATE_V_SCROLLBAR;
- }
- }
- /*
- *----------------------------------------------------------------------
- *
- * ChangListboxOffset --
- *
- * Change the horizontal offset for a listbox.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The listbox may be redrawn to reflect its new horizontal
- * offset.
- *
- *----------------------------------------------------------------------
- */
- static void
- ChangeListboxOffset(listPtr, offset)
- register Listbox *listPtr; /* Information about widget. */
- int offset; /* Desired new "xOffset" for
- * listbox. */
- {
- int maxOffset;
-
- /*
- * Make sure that the new offset is within the allowable range, and
- * round it off to an even multiple of xScrollUnit.
- *
- * Add half a scroll unit to do entry/text-like synchronization.
- * [Bug #225025]
- */
- offset += listPtr->xScrollUnit / 2;
- maxOffset = listPtr->maxWidth - (Tk_Width(listPtr->tkwin) -
- 2*listPtr->inset - 2*listPtr->selBorderWidth)
- + listPtr->xScrollUnit - 1;
- if (offset > maxOffset) {
- offset = maxOffset;
- }
- if (offset < 0) {
- offset = 0;
- }
- offset -= offset % listPtr->xScrollUnit;
- if (offset != listPtr->xOffset) {
- listPtr->xOffset = offset;
- listPtr->flags |= UPDATE_H_SCROLLBAR;
- EventuallyRedrawRange(listPtr, 0, listPtr->nElements-1);
- }
- }
- /*
- *----------------------------------------------------------------------
- *
- * ListboxScanTo --
- *
- * Given a point (presumably of the curent mouse location)
- * drag the view in the window to implement the scan operation.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The view in the window may change.
- *
- *----------------------------------------------------------------------
- */
- static void
- ListboxScanTo(listPtr, x, y)
- register Listbox *listPtr; /* Information about widget. */
- int x; /* X-coordinate to use for scan
- * operation. */
- int y; /* Y-coordinate to use for scan
- * operation. */
- {
- int newTopIndex, newOffset, maxIndex, maxOffset;
-
- maxIndex = listPtr->nElements - listPtr->fullLines;
- maxOffset = listPtr->maxWidth + (listPtr->xScrollUnit - 1)
- - (Tk_Width(listPtr->tkwin) - 2*listPtr->inset
- - 2*listPtr->selBorderWidth - listPtr->xScrollUnit);
- /*
- * Compute new top line for screen by amplifying the difference
- * between the current position and the place where the scan
- * started (the "mark" position). If we run off the top or bottom
- * of the list, then reset the mark point so that the current
- * position continues to correspond to the edge of the window.
- * This means that the picture will start dragging as soon as the
- * mouse reverses direction (without this reset, might have to slide
- * mouse a long ways back before the picture starts moving again).
- */
- newTopIndex = listPtr->scanMarkYIndex
- - (10*(y - listPtr->scanMarkY))/listPtr->lineHeight;
- if (newTopIndex > maxIndex) {
- newTopIndex = listPtr->scanMarkYIndex = maxIndex;
- listPtr->scanMarkY = y;
- } else if (newTopIndex < 0) {
- newTopIndex = listPtr->scanMarkYIndex = 0;
- listPtr->scanMarkY = y;
- }
- ChangeListboxView(listPtr, newTopIndex);
- /*
- * Compute new left edge for display in a similar fashion by amplifying
- * the difference between the current position and the place where the
- * scan started.
- */
- newOffset = listPtr->scanMarkXOffset - (10*(x - listPtr->scanMarkX));
- if (newOffset > maxOffset) {
- newOffset = listPtr->scanMarkXOffset = maxOffset;
- listPtr->scanMarkX = x;
- } else if (newOffset < 0) {
- newOffset = listPtr->scanMarkXOffset = 0;
- listPtr->scanMarkX = x;
- }
- ChangeListboxOffset(listPtr, newOffset);
- }
- /*
- *----------------------------------------------------------------------
- *
- * NearestListboxElement --
- *
- * Given a y-coordinate inside a listbox, compute the index of
- * the element under that y-coordinate (or closest to that
- * y-coordinate).
- *
- * Results:
- * The return value is an index of an element of listPtr. If
- * listPtr has no elements, then 0 is always returned.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
- static int
- NearestListboxElement(listPtr, y)
- register Listbox *listPtr; /* Information about widget. */
- int y; /* Y-coordinate in listPtr's window. */
- {
- int index;
- index = (y - listPtr->inset)/listPtr->lineHeight;
- if (index >= (listPtr->fullLines + listPtr->partialLine)) {
- index = listPtr->fullLines + listPtr->partialLine - 1;
- }
- if (index < 0) {
- index = 0;
- }
- index += listPtr->topIndex;
- if (index >= listPtr->nElements) {
- index = listPtr->nElements-1;
- }
- return index;
- }
- /*
- *----------------------------------------------------------------------
- *
- * ListboxSelect --
- *
- * Select or deselect one or more elements in a listbox..
- *
- * Results:
- * Standard Tcl result.
- *
- * Side effects:
- * All of the elements in the range between first and last are
- * marked as either selected or deselected, depending on the
- * "select" argument. Any items whose state changes are redisplayed.
- * The selection is claimed from X when the number of selected
- * elements changes from zero to non-zero.
- *
- *----------------------------------------------------------------------
- */
- static int
- ListboxSelect(listPtr, first, last, select)
- register Listbox *listPtr; /* Information about widget. */
- int first; /* Index of first element to
- * select or deselect. */
- int last; /* Index of last element to
- * select or deselect. */
- int select; /* 1 means select items, 0 means
- * deselect them. */
- {
- int i, firstRedisplay, oldCount;
- Tcl_HashEntry *entry;
- int new;
-
- if (last < first) {
- i = first;
- first = last;
- last = i;
- }
- if ((last < 0) || (first >= listPtr->nElements)) {
- return TCL_OK;
- }
- if (first < 0) {
- first = 0;
- }
- if (last >= listPtr->nElements) {
- last = listPtr->nElements - 1;
- }
- oldCount = listPtr->numSelected;
- firstRedisplay = -1;
- /*
- * For each index in the range, find it in our selection hash table.
- * If it's not there but should be, add it. If it's there but shouldn't
- * be, remove it.
- */
- for (i = first; i <= last; i++) {
- entry = Tcl_FindHashEntry(listPtr->selection, (char *)i);
- if (entry != NULL) {
- if (!select) {
- Tcl_DeleteHashEntry(entry);
- listPtr->numSelected--;
- if (firstRedisplay < 0) {
- firstRedisplay = i;
- }
- }
- } else {
- if (select) {
- entry = Tcl_CreateHashEntry(listPtr->selection,
- (char *)i, &new);
- Tcl_SetHashValue(entry, (ClientData) NULL);
- listPtr->numSelected++;
- if (firstRedisplay < 0) {
- firstRedisplay = i;
- }
- }
- }
- }
- if (firstRedisplay >= 0) {
- EventuallyRedrawRange(listPtr, first, last);
- }
- if ((oldCount == 0) && (listPtr->numSelected > 0)
- && (listPtr->exportSelection)) {
- Tk_OwnSelection(listPtr->tkwin, XA_PRIMARY, ListboxLostSelection,
- (ClientData) listPtr);
- }
- return TCL_OK;
- }
- /*
- *----------------------------------------------------------------------
- *
- * ListboxFetchSelection --
- *
- * This procedure is called back by Tk when the selection is
- * requested by someone. It returns part or all of the selection
- * in a buffer provided by the caller.
- *
- * Results:
- * The return value is the number of non-NULL bytes stored
- * at buffer. Buffer is filled (or partially filled) with a
- * NULL-terminated string containing part or all of the selection,
- * as given by offset and maxBytes. The selection is returned
- * as a Tcl list with one list element for each element in the
- * listbox.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
- static int
- ListboxFetchSelection(clientData, offset, buffer, maxBytes)
- ClientData clientData; /* Information about listbox widget. */
- int offset; /* Offset within selection of first
- * byte to be returned. */
- char *buffer; /* Location in which to place
- * selection. */
- int maxBytes; /* Maximum number of bytes to place
- * at buffer, not including terminating
- * NULL character. */
- {
- register Listbox *listPtr = (Listbox *) clientData;
- Tcl_DString selection;
- int length, count, needNewline;
- Tcl_Obj *curElement;
- char *stringRep;
- int stringLen;
- Tcl_HashEntry *entry;
- int i;
-
- if (!listPtr->exportSelection) {
- return -1;
- }
- /*
- * Use a dynamic string to accumulate the contents of the selection.
- */
- needNewline = 0;
- Tcl_DStringInit(&selection);
- for (i = 0; i < listPtr->nElements; i++) {
- entry = Tcl_FindHashEntry(listPtr->selection, (char *)i);
- if (entry != NULL) {
- if (needNewline) {
- Tcl_DStringAppend(&selection, "n", 1);
- }
- Tcl_ListObjIndex(listPtr->interp, listPtr->listObj, i,
- &curElement);
- stringRep = Tcl_GetStringFromObj(curElement, &stringLen);
- Tcl_DStringAppend(&selection, stringRep, stringLen);
- needNewline = 1;
- }
- }
- length = Tcl_DStringLength(&selection);
- if (length == 0) {
- return -1;
- }
- /*
- * Copy the requested portion of the selection to the buffer.
- */
- count = length - offset;
- if (count <= 0) {
- count = 0;
- } else {
- if (count > maxBytes) {
- count = maxBytes;
- }
- memcpy((VOID *) buffer,
- (VOID *) (Tcl_DStringValue(&selection) + offset),
- (size_t) count);
- }
- buffer[count] = ' ';
- Tcl_DStringFree(&selection);
- return count;
- }
- /*
- *----------------------------------------------------------------------
- *
- * ListboxLostSelection --
- *
- * This procedure is called back by Tk when the selection is
- * grabbed away from a listbox widget.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The existing selection is unhighlighted, and the window is
- * marked as not containing a selection.
- *
- *----------------------------------------------------------------------
- */
- static void
- ListboxLostSelection(clientData)
- ClientData clientData; /* Information about listbox widget. */
- {
- register Listbox *listPtr = (Listbox *) clientData;
-
- if ((listPtr->exportSelection) && (listPtr->nElements > 0)) {
- ListboxSelect(listPtr, 0, listPtr->nElements-1, 0);
- }
- }
- /*
- *----------------------------------------------------------------------
- *
- * EventuallyRedrawRange --
- *
- * Ensure that a given range of elements is eventually redrawn on
- * the display (if those elements in fact appear on the display).
- *
- * Results:
- * None.
- *
- * Side effects:
- * Information gets redisplayed.
- *
- *----------------------------------------------------------------------
- */
- static void
- EventuallyRedrawRange(listPtr, first, last)
- register Listbox *listPtr; /* Information about widget. */
- int first; /* Index of first element in list
- * that needs to be redrawn. */
- int last; /* Index of last element in list
- * that needs to be redrawn. May
- * be less than first;
- * these just bracket a range. */
- {
- /* We don't have to register a redraw callback if one is already pending,
- * or if the window doesn't exist, or if the window isn't mapped */
- if ((listPtr->flags & REDRAW_PENDING)
- || (listPtr->flags & LISTBOX_DELETED)
- || !Tk_IsMapped(listPtr->tkwin)) {
- return;
- }
- listPtr->flags |= REDRAW_PENDING;
- Tcl_DoWhenIdle(DisplayListbox, (ClientData) listPtr);
- }
- /*
- *----------------------------------------------------------------------
- *
- * ListboxUpdateVScrollbar --
- *
- * This procedure is invoked whenever information has changed in
- * a listbox in a way that would invalidate a vertical scrollbar
- * display. If there is an associated scrollbar, then this command
- * updates it by invoking a Tcl command.
- *
- * Results:
- * None.
- *
- * Side effects:
- * A Tcl command is invoked, and an additional command may be
- * invoked to process errors in the command.
- *
- *----------------------------------------------------------------------
- */
- static void
- ListboxUpdateVScrollbar(listPtr)
- register Listbox *listPtr; /* Information about widget. */
- {
- char string[TCL_DOUBLE_SPACE * 2];
- double first, last;
- int result;
- Tcl_Interp *interp;
-
- if (listPtr->yScrollCmd == NULL) {
- return;
- }
- if (listPtr->nElements == 0) {
- first = 0.0;
- last = 1.0;
- } else {
- first = listPtr->topIndex/((double) listPtr->nElements);
- last = (listPtr->topIndex+listPtr->fullLines)
- /((double) listPtr->nElements);
- if (last > 1.0) {
- last = 1.0;
- }
- }
- sprintf(string, " %g %g", first, last);
- /*
- * We must hold onto the interpreter from the listPtr because the data
- * at listPtr might be freed as a result of the Tcl_VarEval.
- */
-
- interp = listPtr->interp;
- Tcl_Preserve((ClientData) interp);
- result = Tcl_VarEval(interp, listPtr->yScrollCmd, string,
- (char *) NULL);
- if (result != TCL_OK) {
- Tcl_AddErrorInfo(interp,
- "n (vertical scrolling command executed by listbox)");
- Tcl_BackgroundError(interp);
- }
- Tcl_Release((ClientData) interp);
- }
- /*
- *----------------------------------------------------------------------
- *
- * ListboxUpdateHScrollbar --
- *
- * This procedure is invoked whenever information has changed in
- * a listbox in a way that would invalidate a horizontal scrollbar
- * display. If there is an associated horizontal scrollbar, then
- * this command updates it by invoking a Tcl command.
- *
- * Results:
- * None.
- *
- * Side effects:
- * A Tcl command is invoked, and an additional command may be
- * invoked to process errors in the command.
- *
- *----------------------------------------------------------------------
- */
- static void
- ListboxUpdateHScrollbar(listPtr)
- register Listbox *listPtr; /* Information about widget. */
- {
- char string[TCL_DOUBLE_SPACE * 2];
- int result, windowWidth;
- double first, last;
- Tcl_Interp *interp;
- if (listPtr->xScrollCmd == NULL) {
- return;
- }
- windowWidth = Tk_Width(listPtr->tkwin) - 2*(listPtr->inset
- + listPtr->selBorderWidth);
- if (listPtr->maxWidth == 0) {
- first = 0;
- last = 1.0;
- } else {
- first = listPtr->xOffset/((double) listPtr->maxWidth);
- last = (listPtr->xOffset + windowWidth)
- /((double) listPtr->maxWidth);
- if (last > 1.0) {
- last = 1.0;
- }
- }
- sprintf(string, " %g %g", first, last);
- /*
- * We must hold onto the interpreter because the data referred to at
- * listPtr might be freed as a result of the call to Tcl_VarEval.
- */
-
- interp = listPtr->interp;
- Tcl_Preserve((ClientData) interp);
- result = Tcl_VarEval(interp, listPtr->xScrollCmd, string,
- (char *) NULL);
- if (result != TCL_OK) {
- Tcl_AddErrorInfo(interp,
- "n (horizontal scrolling command executed by listbox)");
- Tcl_BackgroundError(interp);
- }
- Tcl_Release((ClientData) interp);
- }
- /*
- *----------------------------------------------------------------------
- *
- * ListboxListVarProc --
- *
- * Called whenever the trace on the listbox list var fires.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
- static char *
- ListboxListVarProc(clientData, interp, name1, name2, flags)
- ClientData clientData; /* Information about button. */
- Tcl_Interp *interp; /* Interpreter containing variable. */
- CONST char *name1; /* Not used. */
- CONST char *name2; /* Not used. */
- int flags; /* Information about what happened. */
- {
- Listbox *listPtr = (Listbox *)clientData;
- Tcl_Obj *oldListObj, *varListObj;
- int oldLength;
- int i;
- Tcl_HashEntry *entry;
-
- /* Bwah hahahaha -- puny mortal, you can't unset a -listvar'd variable! */
- if (flags & TCL_TRACE_UNSETS) {
- if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) {
- Tcl_SetVar2Ex(interp, listPtr->listVarName,
- (char *)NULL, listPtr->listObj, TCL_GLOBAL_ONLY);
- Tcl_TraceVar(interp, listPtr->listVarName,
- TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
- ListboxListVarProc, clientData);
- return (char *)NULL;
- }
- } else {
- oldListObj = listPtr->listObj;
- varListObj = Tcl_GetVar2Ex(listPtr->interp, listPtr->listVarName,
- (char *)NULL, TCL_GLOBAL_ONLY);
- /*
- * Make sure the new value is a good list; if it's not, disallow
- * the change -- the fact that it is a listvar means that it must
- * always be a valid list -- and return an error message.
- */
- if (Tcl_ListObjLength(listPtr->interp, varListObj, &i) != TCL_OK) {
- Tcl_SetVar2Ex(interp, listPtr->listVarName, (char *)NULL,
- oldListObj, TCL_GLOBAL_ONLY);
- return("invalid listvar value");
- }
-
- listPtr->listObj = varListObj;
- /* Incr the obj ref count so it doesn't vanish if the var is unset */
- Tcl_IncrRefCount(listPtr->listObj);
- /* Clean up the ref to our old list obj */
- Tcl_DecrRefCount(oldListObj);
- }
- /*
- * If the list length has decreased, then we should clean up selection and
- * attributes information for elements past the end of the new list
- */
- oldLength = listPtr->nElements;
- Tcl_ListObjLength(listPtr->interp, listPtr->listObj, &listPtr->nElements);
- if (listPtr->nElements < oldLength) {
- for (i = listPtr->nElements; i < oldLength; i++) {
- /* Clean up selection */
- entry = Tcl_FindHashEntry(listPtr->selection, (char *)i);
- if (entry != NULL) {
- listPtr->numSelected--;
- Tcl_DeleteHashEntry(entry);
- }
- /* Clean up attributes */
- entry = Tcl_FindHashEntry(listPtr->itemAttrTable, (char *)i);
- if (entry != NULL) {
- ckfree((char *)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 (char*)NULL;
- }
- /*
- *----------------------------------------------------------------------
- *
- * MigrateHashEntries --
- *
- * Given a hash table with entries keyed by a single integer value,
- * move all entries in a given range by a fixed amount, so that
- * if in the original table there was an entry with key n and
- * the offset was i, in the new table that entry would have key n + i.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Rekeys some hash table entries.
- *
- *----------------------------------------------------------------------
- */
- static void
- MigrateHashEntries(table, first, last, offset)
- Tcl_HashTable *table;
- int first;
- int last;
- int offset;
- {
- int i, new;
- Tcl_HashEntry *entry;
- ClientData clientData;
- if (offset == 0) {
- return;
- }
- /* It's more efficient to do one if/else and nest the for loops inside,
- * although we could avoid some code duplication if we nested the if/else
- * inside the for loops */
- if (offset > 0) {
- for (i = last; i >= first; i--) {
- entry = Tcl_FindHashEntry(table, (char *)i);
- if (entry != NULL) {
- clientData = Tcl_GetHashValue(entry);
- Tcl_DeleteHashEntry(entry);
- entry = Tcl_CreateHashEntry(table, (char *)(i + offset), &new);
- Tcl_SetHashValue(entry, clientData);
- }
- }
- } else {
- for (i = first; i <= last; i++) {
- entry = Tcl_FindHashEntry(table, (char *)i);
- if (entry != NULL) {
- clientData = Tcl_GetHashValue(entry);
- Tcl_DeleteHashEntry(entry);
- entry = Tcl_CreateHashEntry(table, (char *)(i + offset), &new);
- Tcl_SetHashValue(entry, clientData);
- }
- }
- }
- return;
- }