ag/cpython-source-deps
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
753ac6b03713e240bba9599d9dac89df8e8605f9
cpython-source-deps/generic/tkListbox.c
Zachary Ware b1c28856bb Import Tk 8.6.6 (as of svn r86089)
2017-05-22 16:13:37 -05:00

3647 lines
102 KiB
C
Raw Blame History

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