diff options
Diffstat (limited to 'tk8.6/generic/ttk/ttkTheme.c')
| -rw-r--r-- | tk8.6/generic/ttk/ttkTheme.c | 1750 |
1 files changed, 0 insertions, 1750 deletions
diff --git a/tk8.6/generic/ttk/ttkTheme.c b/tk8.6/generic/ttk/ttkTheme.c deleted file mode 100644 index 2f95962..0000000 --- a/tk8.6/generic/ttk/ttkTheme.c +++ /dev/null @@ -1,1750 +0,0 @@ -/* - * ttkTheme.c -- - * - * This file implements the widget styles and themes support. - * - * Copyright (c) 2002 Frederic Bonnet - * Copyright (c) 2003 Joe English - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include <stdlib.h> -#include <string.h> -#include <tk.h> -#include <tkInt.h> -#include "ttkThemeInt.h" - -#define PKG_ASSOC_KEY "Ttk" - -/*------------------------------------------------------------------------ - * +++ Styles. - * - * Invariants: - * If styleName contains a dot, parentStyle->styleName is everything - * after the first dot; otherwise, parentStyle is the theme's root - * style ".". The root style's parentStyle is NULL. - * - */ - -typedef struct Ttk_Style_ -{ - const char *styleName; /* points to hash table key */ - Tcl_HashTable settingsTable; /* KEY: string; VALUE: StateMap */ - Tcl_HashTable defaultsTable; /* KEY: string; VALUE: resource */ - Ttk_LayoutTemplate layoutTemplate; /* Layout template for style, or NULL */ - Ttk_Style parentStyle; /* Previous style in chain */ - Ttk_ResourceCache cache; /* Back-pointer to resource cache */ -} Style; - -static Style *NewStyle() -{ - Style *stylePtr = ckalloc(sizeof(Style)); - - stylePtr->styleName = NULL; - stylePtr->parentStyle = NULL; - stylePtr->layoutTemplate = NULL; - stylePtr->cache = NULL; - Tcl_InitHashTable(&stylePtr->settingsTable, TCL_STRING_KEYS); - Tcl_InitHashTable(&stylePtr->defaultsTable, TCL_STRING_KEYS); - - return stylePtr; -} - -static void FreeStyle(Style *stylePtr) -{ - Tcl_HashSearch search; - Tcl_HashEntry *entryPtr; - - entryPtr = Tcl_FirstHashEntry(&stylePtr->settingsTable, &search); - while (entryPtr != NULL) { - Ttk_StateMap stateMap = Tcl_GetHashValue(entryPtr); - Tcl_DecrRefCount(stateMap); - entryPtr = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(&stylePtr->settingsTable); - - entryPtr = Tcl_FirstHashEntry(&stylePtr->defaultsTable, &search); - while (entryPtr != NULL) { - Tcl_Obj *defaultValue = Tcl_GetHashValue(entryPtr); - Tcl_DecrRefCount(defaultValue); - entryPtr = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(&stylePtr->defaultsTable); - - Ttk_FreeLayoutTemplate(stylePtr->layoutTemplate); - - ckfree(stylePtr); -} - -/* - * Ttk_StyleMap -- - * Look up state-specific option value from specified style. - */ -Tcl_Obj *Ttk_StyleMap(Ttk_Style style, const char *optionName, Ttk_State state) -{ - while (style) { - Tcl_HashEntry *entryPtr = - Tcl_FindHashEntry(&style->settingsTable, optionName); - if (entryPtr) { - Ttk_StateMap stateMap = Tcl_GetHashValue(entryPtr); - return Ttk_StateMapLookup(NULL, stateMap, state); - } - style = style->parentStyle; - } - return 0; -} - -/* - * Ttk_StyleDefault -- - * Look up default resource setting the in the specified style. - */ -Tcl_Obj *Ttk_StyleDefault(Ttk_Style style, const char *optionName) -{ - while (style) { - Tcl_HashEntry *entryPtr = - Tcl_FindHashEntry(&style->defaultsTable, optionName); - if (entryPtr) - return Tcl_GetHashValue(entryPtr); - style= style->parentStyle; - } - return 0; -} - -/*------------------------------------------------------------------------ - * +++ Elements. - */ -typedef const Tk_OptionSpec **OptionMap; - /* array of Tk_OptionSpecs mapping widget options to element options */ - -struct Ttk_ElementClass_ { - const char *name; /* Points to hash table key */ - Ttk_ElementSpec *specPtr; /* Template provided during registration. */ - void *clientData; /* Client data passed in at registration time */ - void *elementRecord; /* Scratch buffer for element record storage */ - int nResources; /* #Element options */ - Tcl_Obj **defaultValues; /* Array of option default values */ - Tcl_HashTable optMapCache; /* Map: Tk_OptionTable * -> OptionMap */ -}; - -/* TTKGetOptionSpec -- - * Look up a Tk_OptionSpec by name from a Tk_OptionTable, - * and verify that it's compatible with the specified Tk_OptionType, - * along with other constraints (see below). - */ -static const Tk_OptionSpec *TTKGetOptionSpec( - const char *optionName, - Tk_OptionTable optionTable, - Tk_OptionType optionType) -{ - const Tk_OptionSpec *optionSpec = TkGetOptionSpec(optionName, optionTable); - - if (!optionSpec) - return 0; - - /* Make sure widget option has a Tcl_Obj* entry: - */ - if (optionSpec->objOffset < 0) { - return 0; - } - - /* Grrr. Ignore accidental mismatches caused by prefix-matching: - */ - if (strcmp(optionSpec->optionName, optionName)) { - return 0; - } - - /* Ensure that the widget option type is compatible with - * the element option type. - * - * TK_OPTION_STRING element options are compatible with anything. - * As a workaround for the workaround for Bug #967209, - * TK_OPTION_STRING widget options are also compatible with anything - * (see <<NOTE-NULLOPTIONS>>). - */ - if ( optionType != TK_OPTION_STRING - && optionSpec->type != TK_OPTION_STRING - && optionType != optionSpec->type) - { - return 0; - } - - return optionSpec; -} - -/* BuildOptionMap -- - * Construct the mapping from element options to widget options. - */ -static OptionMap -BuildOptionMap(Ttk_ElementClass *elementClass, Tk_OptionTable optionTable) -{ - OptionMap optionMap = ckalloc( - sizeof(const Tk_OptionSpec) * elementClass->nResources + 1); - int i; - - for (i = 0; i < elementClass->nResources; ++i) { - Ttk_ElementOptionSpec *e = elementClass->specPtr->options+i; - optionMap[i] = TTKGetOptionSpec(e->optionName, optionTable, e->type); - } - - return optionMap; -} - -/* GetOptionMap -- - * Return a cached OptionMap matching the specified optionTable - * for the specified element, creating it if necessary. - */ -static OptionMap -GetOptionMap(Ttk_ElementClass *elementClass, Tk_OptionTable optionTable) -{ - OptionMap optionMap; - int isNew; - Tcl_HashEntry *entryPtr = Tcl_CreateHashEntry( - &elementClass->optMapCache, (void*)optionTable, &isNew); - - if (isNew) { - optionMap = BuildOptionMap(elementClass, optionTable); - Tcl_SetHashValue(entryPtr, optionMap); - } else { - optionMap = Tcl_GetHashValue(entryPtr); - } - - return optionMap; -} - -/* - * NewElementClass -- - * Allocate and initialize an element class record - * from the specified element specification. - */ -static Ttk_ElementClass * -NewElementClass(const char *name, Ttk_ElementSpec *specPtr,void *clientData) -{ - Ttk_ElementClass *elementClass = ckalloc(sizeof(Ttk_ElementClass)); - int i; - - elementClass->name = name; - elementClass->specPtr = specPtr; - elementClass->clientData = clientData; - elementClass->elementRecord = ckalloc(specPtr->elementSize); - - /* Count #element resources: - */ - for (i = 0; specPtr->options[i].optionName != 0; ++i) - continue; - elementClass->nResources = i; - - /* Initialize default values: - */ - elementClass->defaultValues = - ckalloc(elementClass->nResources * sizeof(Tcl_Obj *) + 1); - for (i=0; i < elementClass->nResources; ++i) { - const char *defaultValue = specPtr->options[i].defaultValue; - if (defaultValue) { - elementClass->defaultValues[i] = Tcl_NewStringObj(defaultValue,-1); - Tcl_IncrRefCount(elementClass->defaultValues[i]); - } else { - elementClass->defaultValues[i] = 0; - } - } - - /* Initialize option map cache: - */ - Tcl_InitHashTable(&elementClass->optMapCache, TCL_ONE_WORD_KEYS); - - return elementClass; -} - -/* - * FreeElementClass -- - * Release resources associated with an element class record. - */ -static void FreeElementClass(Ttk_ElementClass *elementClass) -{ - Tcl_HashSearch search; - Tcl_HashEntry *entryPtr; - int i; - - /* - * Free default values: - */ - for (i = 0; i < elementClass->nResources; ++i) { - if (elementClass->defaultValues[i]) { - Tcl_DecrRefCount(elementClass->defaultValues[i]); - } - } - ckfree(elementClass->defaultValues); - - /* - * Free option map cache: - */ - entryPtr = Tcl_FirstHashEntry(&elementClass->optMapCache, &search); - while (entryPtr != NULL) { - ckfree(Tcl_GetHashValue(entryPtr)); - entryPtr = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(&elementClass->optMapCache); - - ckfree(elementClass->elementRecord); - ckfree(elementClass); -} - -/*------------------------------------------------------------------------ - * +++ Themes. - */ - -static int ThemeEnabled(Ttk_Theme theme, void *clientData) { return 1; } - /* Default ThemeEnabledProc -- always return true */ - -typedef struct Ttk_Theme_ -{ - Ttk_Theme parentPtr; /* Parent theme. */ - Tcl_HashTable elementTable; /* Map element names to class records */ - Tcl_HashTable styleTable; /* Map style names to Styles */ - Ttk_Style rootStyle; /* "." style, root of chain */ - Ttk_ThemeEnabledProc *enabledProc; /* Function called by SetTheme */ - void *enabledData; /* ClientData for enabledProc */ - Ttk_ResourceCache cache; /* Back-pointer to resource cache */ -} Theme; - -static Theme *NewTheme(Ttk_ResourceCache cache, Ttk_Theme parent) -{ - Theme *themePtr = ckalloc(sizeof(Theme)); - Tcl_HashEntry *entryPtr; - int unused; - - themePtr->parentPtr = parent; - themePtr->enabledProc = ThemeEnabled; - themePtr->enabledData = NULL; - themePtr->cache = cache; - Tcl_InitHashTable(&themePtr->elementTable, TCL_STRING_KEYS); - Tcl_InitHashTable(&themePtr->styleTable, TCL_STRING_KEYS); - - /* - * Create root style "." - */ - entryPtr = Tcl_CreateHashEntry(&themePtr->styleTable, ".", &unused); - themePtr->rootStyle = NewStyle(); - themePtr->rootStyle->styleName = - Tcl_GetHashKey(&themePtr->styleTable, entryPtr); - themePtr->rootStyle->cache = themePtr->cache; - Tcl_SetHashValue(entryPtr, themePtr->rootStyle); - - return themePtr; -} - -static void FreeTheme(Theme *themePtr) -{ - Tcl_HashSearch search; - Tcl_HashEntry *entryPtr; - - /* - * Free element table: - */ - entryPtr = Tcl_FirstHashEntry(&themePtr->elementTable, &search); - while (entryPtr != NULL) { - Ttk_ElementClass *elementClass = Tcl_GetHashValue(entryPtr); - FreeElementClass(elementClass); - entryPtr = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(&themePtr->elementTable); - - /* - * Free style table: - */ - entryPtr = Tcl_FirstHashEntry(&themePtr->styleTable, &search); - while (entryPtr != NULL) { - Style *stylePtr = Tcl_GetHashValue(entryPtr); - FreeStyle(stylePtr); - entryPtr = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(&themePtr->styleTable); - - /* - * Free theme record: - */ - ckfree(themePtr); - - return; -} - -/* - * Element constructors. - */ -typedef struct { - Ttk_ElementFactory factory; - void *clientData; -} FactoryRec; - -/* - * Cleanup records: - */ -typedef struct CleanupStruct { - void *clientData; - Ttk_CleanupProc *cleanupProc; - struct CleanupStruct *next; -} Cleanup; - -/*------------------------------------------------------------------------ - * +++ Master style package data structure. - */ -typedef struct -{ - Tcl_Interp *interp; /* Owner interp */ - Tcl_HashTable themeTable; /* KEY: name; VALUE: Theme pointer */ - Tcl_HashTable factoryTable; /* KEY: name; VALUE: FactoryRec ptr */ - Theme *defaultTheme; /* Default theme; global fallback*/ - Theme *currentTheme; /* Currently-selected theme */ - Cleanup *cleanupList; /* Cleanup records */ - Ttk_ResourceCache cache; /* Resource cache */ - int themeChangePending; /* scheduled ThemeChangedProc call? */ -} StylePackageData; - -static void ThemeChangedProc(ClientData); /* Forward */ - -/* Ttk_StylePkgFree -- - * Cleanup procedure for StylePackageData. - */ -static void Ttk_StylePkgFree(ClientData clientData, Tcl_Interp *interp) -{ - StylePackageData *pkgPtr = clientData; - Tcl_HashSearch search; - Tcl_HashEntry *entryPtr; - Cleanup *cleanup; - - /* - * Cancel any pending ThemeChanged calls: - */ - if (pkgPtr->themeChangePending) { - Tcl_CancelIdleCall(ThemeChangedProc, pkgPtr); - } - - /* - * Free themes. - */ - entryPtr = Tcl_FirstHashEntry(&pkgPtr->themeTable, &search); - while (entryPtr != NULL) { - Theme *themePtr = Tcl_GetHashValue(entryPtr); - FreeTheme(themePtr); - entryPtr = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(&pkgPtr->themeTable); - - /* - * Free element constructor table: - */ - entryPtr = Tcl_FirstHashEntry(&pkgPtr->factoryTable, &search); - while (entryPtr != NULL) { - ckfree(Tcl_GetHashValue(entryPtr)); - entryPtr = Tcl_NextHashEntry(&search); - } - Tcl_DeleteHashTable(&pkgPtr->factoryTable); - - /* - * Release cache: - */ - Ttk_FreeResourceCache(pkgPtr->cache); - - /* - * Call all registered cleanup procedures: - */ - cleanup = pkgPtr->cleanupList; - while (cleanup) { - Cleanup *next = cleanup->next; - cleanup->cleanupProc(cleanup->clientData); - ckfree(cleanup); - cleanup = next; - } - - ckfree(pkgPtr); -} - -/* - * GetStylePackageData -- - * Look up the package data registered with the interp. - */ - -static StylePackageData *GetStylePackageData(Tcl_Interp *interp) -{ - return Tcl_GetAssocData(interp, PKG_ASSOC_KEY, NULL); -} - -/* - * Ttk_RegisterCleanup -- - * - * Register a function to be called when a theme engine is deleted. - * (This only happens when the main interp is destroyed). The cleanup - * function is called with the current Tcl interpreter and the client - * data provided here. - * - */ -void Ttk_RegisterCleanup( - Tcl_Interp *interp, ClientData clientData, Ttk_CleanupProc *cleanupProc) -{ - StylePackageData *pkgPtr = GetStylePackageData(interp); - Cleanup *cleanup = ckalloc(sizeof(*cleanup)); - - cleanup->clientData = clientData; - cleanup->cleanupProc = cleanupProc; - cleanup->next = pkgPtr->cleanupList; - pkgPtr->cleanupList = cleanup; -} - -/* ThemeChangedProc -- - * Notify all widgets that the theme has been changed. - * Scheduled as an idle callback; clientData is a StylePackageData *. - * - * Sends a <<ThemeChanged>> event to every widget in the hierarchy. - * Widgets respond to this by calling the WorldChanged class proc, - * which in turn recreates the layout. - * - * The Tk C API doesn't doesn't provide an easy way to traverse - * the widget hierarchy, so this is done by evaluating a Tcl script. - */ - -static void ThemeChangedProc(ClientData clientData) -{ - static char ThemeChangedScript[] = "ttk::ThemeChanged"; - StylePackageData *pkgPtr = clientData; - - int code = Tcl_EvalEx(pkgPtr->interp, ThemeChangedScript, -1, TCL_EVAL_GLOBAL); - if (code != TCL_OK) { - Tcl_BackgroundException(pkgPtr->interp, code); - } - pkgPtr->themeChangePending = 0; -} - -/* - * ThemeChanged -- - * Schedule a call to ThemeChanged if one is not already pending. - */ -static void ThemeChanged(StylePackageData *pkgPtr) -{ - if (!pkgPtr->themeChangePending) { - Tcl_DoWhenIdle(ThemeChangedProc, pkgPtr); - pkgPtr->themeChangePending = 1; - } -} - -/* - * Ttk_CreateTheme -- - * Create a new theme and register it in the global theme table. - * - * Returns: - * Pointer to new Theme structure; NULL if named theme already exists. - * Leaves an error message in interp's result on error. - */ - -Ttk_Theme -Ttk_CreateTheme( - Tcl_Interp *interp, /* Interpreter in which to create theme */ - const char *name, /* Name of the theme to create. */ - Ttk_Theme parent) /* Parent/fallback theme, NULL for default */ -{ - StylePackageData *pkgPtr = GetStylePackageData(interp); - Tcl_HashEntry *entryPtr; - int newEntry; - Theme *themePtr; - - entryPtr = Tcl_CreateHashEntry(&pkgPtr->themeTable, name, &newEntry); - if (!newEntry) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Theme %s already exists", name)); - Tcl_SetErrorCode(interp, "TTK", "THEME", "EXISTS", NULL); - return NULL; - } - - /* - * Initialize new theme: - */ - if (!parent) parent = pkgPtr->defaultTheme; - - themePtr = NewTheme(pkgPtr->cache, parent); - Tcl_SetHashValue(entryPtr, themePtr); - - return themePtr; -} - -/* - * Ttk_SetThemeEnabledProc -- - * Sets a procedure that is used to check that this theme is available. - */ - -void Ttk_SetThemeEnabledProc( - Ttk_Theme theme, Ttk_ThemeEnabledProc enabledProc, void *enabledData) -{ - theme->enabledProc = enabledProc; - theme->enabledData = enabledData; -} - -/* - * LookupTheme -- - * Retrieve a registered theme by name. If not found, - * returns NULL and leaves an error message in interp's result. - */ - -static Ttk_Theme LookupTheme( - Tcl_Interp *interp, /* where to leave error messages */ - StylePackageData *pkgPtr, /* style package master record */ - const char *name) /* theme name */ -{ - Tcl_HashEntry *entryPtr; - - entryPtr = Tcl_FindHashEntry(&pkgPtr->themeTable, name); - if (!entryPtr) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "theme \"%s\" doesn't exist", name)); - Tcl_SetErrorCode(interp, "TTK", "LOOKUP", "THEME", name, NULL); - return NULL; - } - - return Tcl_GetHashValue(entryPtr); -} - -/* - * Ttk_GetTheme -- - * Public interface to LookupTheme. - */ -Ttk_Theme Ttk_GetTheme(Tcl_Interp *interp, const char *themeName) -{ - StylePackageData *pkgPtr = GetStylePackageData(interp); - - return LookupTheme(interp, pkgPtr, themeName); -} - -Ttk_Theme Ttk_GetCurrentTheme(Tcl_Interp *interp) -{ - StylePackageData *pkgPtr = GetStylePackageData(interp); - return pkgPtr->currentTheme; -} - -Ttk_Theme Ttk_GetDefaultTheme(Tcl_Interp *interp) -{ - StylePackageData *pkgPtr = GetStylePackageData(interp); - return pkgPtr->defaultTheme; -} - -/* - * Ttk_UseTheme -- - * Set the current theme, notify all widgets that the theme has changed. - */ -int Ttk_UseTheme(Tcl_Interp *interp, Ttk_Theme theme) -{ - StylePackageData *pkgPtr = GetStylePackageData(interp); - - /* - * Check if selected theme is enabled: - */ - while (theme && !theme->enabledProc(theme, theme->enabledData)) { - theme = theme->parentPtr; - } - if (!theme) { - /* This shouldn't happen -- default theme should always work */ - Tcl_Panic("No themes available?"); - return TCL_ERROR; - } - - pkgPtr->currentTheme = theme; - ThemeChanged(pkgPtr); - return TCL_OK; -} - -/* - * Ttk_GetResourceCache -- - * Return the resource cache associated with 'interp' - */ -Ttk_ResourceCache -Ttk_GetResourceCache(Tcl_Interp *interp) -{ - StylePackageData *pkgPtr = GetStylePackageData(interp); - return pkgPtr->cache; -} - -/* - * Register a new layout specification with a style. - * @@@ TODO: Make sure layoutName is not ".", root style must not have a layout - */ -MODULE_SCOPE -void Ttk_RegisterLayoutTemplate( - Ttk_Theme theme, /* Target theme */ - const char *layoutName, /* Name of new layout */ - Ttk_LayoutTemplate layoutTemplate) /* Template */ -{ - Ttk_Style style = Ttk_GetStyle(theme, layoutName); - if (style->layoutTemplate) { - Ttk_FreeLayoutTemplate(style->layoutTemplate); - } - style->layoutTemplate = layoutTemplate; -} - -void Ttk_RegisterLayout( - Ttk_Theme themePtr, /* Target theme */ - const char *layoutName, /* Name of new layout */ - Ttk_LayoutSpec specPtr) /* Static layout information */ -{ - Ttk_LayoutTemplate layoutTemplate = Ttk_BuildLayoutTemplate(specPtr); - Ttk_RegisterLayoutTemplate(themePtr, layoutName, layoutTemplate); -} - -/* - * Ttk_GetStyle -- - * Look up a Style from a Theme, create new style if not found. - */ -Ttk_Style Ttk_GetStyle(Ttk_Theme themePtr, const char *styleName) -{ - Tcl_HashEntry *entryPtr; - int newStyle; - - entryPtr = Tcl_CreateHashEntry(&themePtr->styleTable, styleName, &newStyle); - if (newStyle) { - Ttk_Style stylePtr = NewStyle(); - const char *dot = strchr(styleName, '.'); - - if (dot) { - stylePtr->parentStyle = Ttk_GetStyle(themePtr, dot + 1); - } else { - stylePtr->parentStyle = themePtr->rootStyle; - } - - stylePtr->styleName = Tcl_GetHashKey(&themePtr->styleTable, entryPtr); - stylePtr->cache = stylePtr->parentStyle->cache; - Tcl_SetHashValue(entryPtr, stylePtr); - return stylePtr; - } - return Tcl_GetHashValue(entryPtr); -} - -/* FindLayoutTemplate -- - * Locate a layout template in the layout table, checking - * generic names to specific names first, then looking for - * the full name in the parent theme. - */ -Ttk_LayoutTemplate -Ttk_FindLayoutTemplate(Ttk_Theme themePtr, const char *layoutName) -{ - while (themePtr) { - Ttk_Style stylePtr = Ttk_GetStyle(themePtr, layoutName); - while (stylePtr) { - if (stylePtr->layoutTemplate) { - return stylePtr->layoutTemplate; - } - stylePtr = stylePtr->parentStyle; - } - themePtr = themePtr->parentPtr; - } - return NULL; -} - -const char *Ttk_StyleName(Ttk_Style stylePtr) -{ - return stylePtr->styleName; -} - -/* - * Ttk_GetElement -- - * Look up an element class by name in a given theme. - * If not found, try generic element names in this theme, then - * repeat the lookups in the parent theme. - * If not found, return the null element. - */ -Ttk_ElementClass *Ttk_GetElement(Ttk_Theme themePtr, const char *elementName) -{ - Tcl_HashEntry *entryPtr; - const char *dot = elementName; - - /* - * Check if element has already been registered: - */ - entryPtr = Tcl_FindHashEntry(&themePtr->elementTable, elementName); - if (entryPtr) { - return Tcl_GetHashValue(entryPtr); - } - - /* - * Check generic names: - */ - while (!entryPtr && ((dot = strchr(dot, '.')) != NULL)) { - dot++; - entryPtr = Tcl_FindHashEntry(&themePtr->elementTable, dot); - } - if (entryPtr) { - return Tcl_GetHashValue(entryPtr); - } - - /* - * Check parent theme: - */ - if (themePtr->parentPtr) { - return Ttk_GetElement(themePtr->parentPtr, elementName); - } - - /* - * Not found, and this is the root theme; return null element, "". - * (@@@ SHOULD: signal a background error) - */ - entryPtr = Tcl_FindHashEntry(&themePtr->elementTable, ""); - /* ASSERT: entryPtr != 0 */ - return Tcl_GetHashValue(entryPtr); -} - -const char *Ttk_ElementClassName(Ttk_ElementClass *elementClass) -{ - return elementClass->name; -} - -/* - * Ttk_RegisterElementFactory -- - * Register a new element factory. - */ -int Ttk_RegisterElementFactory( - Tcl_Interp *interp, const char *name, - Ttk_ElementFactory factory, void *clientData) -{ - StylePackageData *pkgPtr = GetStylePackageData(interp); - FactoryRec *recPtr = ckalloc(sizeof(*recPtr)); - Tcl_HashEntry *entryPtr; - int newEntry; - - recPtr->factory = factory; - recPtr->clientData = clientData; - - entryPtr = Tcl_CreateHashEntry(&pkgPtr->factoryTable, name, &newEntry); - if (!newEntry) { - /* Free old factory: */ - ckfree(Tcl_GetHashValue(entryPtr)); - } - Tcl_SetHashValue(entryPtr, recPtr); - - return TCL_OK; -} - -/* Ttk_CloneElement -- element factory procedure. - * (style element create $name) "from" $theme ?$element? - */ -static int Ttk_CloneElement( - Tcl_Interp *interp, void *clientData, - Ttk_Theme theme, const char *elementName, - int objc, Tcl_Obj *const objv[]) -{ - Ttk_Theme fromTheme; - Ttk_ElementClass *fromElement; - - if (objc <= 0 || objc > 2) { - Tcl_WrongNumArgs(interp, 0, objv, "theme ?element?"); - return TCL_ERROR; - } - - fromTheme = Ttk_GetTheme(interp, Tcl_GetString(objv[0])); - if (!fromTheme) { - return TCL_ERROR; - } - - if (objc == 2) { - fromElement = Ttk_GetElement(fromTheme, Tcl_GetString(objv[1])); - } else { - fromElement = Ttk_GetElement(fromTheme, elementName); - } - if (!fromElement) { - return TCL_ERROR; - } - - if (Ttk_RegisterElement(interp, theme, elementName, - fromElement->specPtr, fromElement->clientData) == NULL) - { - return TCL_ERROR; - } - return TCL_OK; -} - -/* Ttk_RegisterElement-- - * Register an element in the given theme. - * Returns: Element handle if successful, NULL otherwise. - * On failure, leaves an error message in interp's result - * if interp is non-NULL. - */ - -Ttk_ElementClass *Ttk_RegisterElement( - Tcl_Interp *interp, /* Where to leave error messages */ - Ttk_Theme theme, /* Style engine providing the implementation. */ - const char *name, /* Name of new element */ - Ttk_ElementSpec *specPtr, /* Static template information */ - void *clientData) /* application-specific data */ -{ - Ttk_ElementClass *elementClass; - Tcl_HashEntry *entryPtr; - int newEntry; - - if (specPtr->version != TK_STYLE_VERSION_2) { - /* Version mismatch */ - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Internal error: Ttk_RegisterElement (%s): invalid version", - name)); - Tcl_SetErrorCode(interp, "TTK", "REGISTER_ELEMENT", "VERSION", - NULL); - } - return 0; - } - - entryPtr = Tcl_CreateHashEntry(&theme->elementTable, name, &newEntry); - if (!newEntry) { - if (interp) { - Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Duplicate element %s", name)); - Tcl_SetErrorCode(interp, "TTK", "REGISTER_ELEMENT", "DUPE", NULL); - } - return 0; - } - - name = Tcl_GetHashKey(&theme->elementTable, entryPtr); - elementClass = NewElementClass(name, specPtr, clientData); - Tcl_SetHashValue(entryPtr, elementClass); - - return elementClass; -} - -/* Ttk_RegisterElementSpec (deprecated) -- - * Register a new element. - */ -int Ttk_RegisterElementSpec(Ttk_Theme theme, - const char *name, Ttk_ElementSpec *specPtr, void *clientData) -{ - return Ttk_RegisterElement(NULL, theme, name, specPtr, clientData) - ? TCL_OK : TCL_ERROR; -} - -/*------------------------------------------------------------------------ - * +++ Element record initialization. - */ - -/* - * AllocateResource -- - * Extra initialization for element options like TK_OPTION_COLOR, etc. - * - * Returns: 1 if OK, 0 on failure. - * - * Note: if resource allocation fails at this point (just prior - * to drawing an element), there's really no good place to - * report the error. Instead we just silently fail. - */ - -static int AllocateResource( - Ttk_ResourceCache cache, - Tk_Window tkwin, - Tcl_Obj **destPtr, - int optionType) -{ - Tcl_Obj *resource = *destPtr; - - switch (optionType) - { - case TK_OPTION_FONT: - return (*destPtr = Ttk_UseFont(cache, tkwin, resource)) != NULL; - case TK_OPTION_COLOR: - return (*destPtr = Ttk_UseColor(cache, tkwin, resource)) != NULL; - case TK_OPTION_BORDER: - return (*destPtr = Ttk_UseBorder(cache, tkwin, resource)) != NULL; - default: - /* no-op; always succeeds */ - return 1; - } -} - -/* - * InitializeElementRecord -- - * - * Fill in the element record based on the element's option table. - * Resources are initialized from: - * the corresponding widget option if present and non-NULL, - * otherwise the dynamic state map if specified, - * otherwise from the corresponding widget resource if present, - * otherwise the default value specified at registration time. - * - * Returns: - * 1 if OK, 0 if an error is detected. - * - * NOTES: - * Tcl_Obj * reference counts are _NOT_ adjusted. - */ - -static -int InitializeElementRecord( - Ttk_ElementClass *eclass, /* Element instance to initialize */ - Ttk_Style style, /* Style table */ - char *widgetRecord, /* Source of widget option values */ - Tk_OptionTable optionTable, /* Option table describing widget record */ - Tk_Window tkwin, /* Corresponding window */ - Ttk_State state) /* Widget or element state */ -{ - char *elementRecord = eclass->elementRecord; - OptionMap optionMap = GetOptionMap(eclass,optionTable); - int nResources = eclass->nResources; - Ttk_ResourceCache cache = style->cache; - Ttk_ElementOptionSpec *elementOption = eclass->specPtr->options; - - int i; - for (i=0; i<nResources; ++i, ++elementOption) { - Tcl_Obj **dest = (Tcl_Obj **) - (elementRecord + elementOption->offset); - const char *optionName = elementOption->optionName; - Tcl_Obj *dynamicSetting = Ttk_StyleMap(style, optionName, state); - Tcl_Obj *widgetValue = 0; - Tcl_Obj *elementDefault = eclass->defaultValues[i]; - - if (optionMap[i]) { - widgetValue = *(Tcl_Obj **) - (widgetRecord + optionMap[i]->objOffset); - } - - if (widgetValue) { - *dest = widgetValue; - } else if (dynamicSetting) { - *dest = dynamicSetting; - } else { - Tcl_Obj *styleDefault = Ttk_StyleDefault(style, optionName); - *dest = styleDefault ? styleDefault : elementDefault; - } - - if (!AllocateResource(cache, tkwin, dest, elementOption->type)) { - return 0; - } - } - - return 1; -} - -/*------------------------------------------------------------------------ - * +++ Public API. - */ - -/* - * Ttk_QueryStyle -- - * Look up a style option based on the current state. - */ -Tcl_Obj *Ttk_QueryStyle( - Ttk_Style style, /* Style to query */ - void *recordPtr, /* Widget record */ - Tk_OptionTable optionTable, /* Option table describing widget record */ - const char *optionName, /* Option name */ - Ttk_State state) /* Current state */ -{ - const Tk_OptionSpec *optionSpec; - Tcl_Obj *result; - - /* - * Check widget record: - */ - optionSpec = TTKGetOptionSpec(optionName, optionTable, TK_OPTION_ANY); - if (optionSpec) { - result = *(Tcl_Obj**)(((char*)recordPtr) + optionSpec->objOffset); - if (result) { - return result; - } - } - - /* - * Check dynamic settings: - */ - result = Ttk_StyleMap(style, optionName, state); - if (result) { - return result; - } - - /* - * Use style default: - */ - return Ttk_StyleDefault(style, optionName); -} - -/* - * Ttk_ElementSize -- - * Compute the requested size of the given element. - */ - -void -Ttk_ElementSize( - Ttk_ElementClass *eclass, /* Element to query */ - Ttk_Style style, /* Style settings */ - char *recordPtr, /* The widget record. */ - Tk_OptionTable optionTable, /* Description of widget record */ - Tk_Window tkwin, /* The widget window. */ - Ttk_State state, /* Current widget state */ - int *widthPtr, /* Requested width */ - int *heightPtr, /* Reqested height */ - Ttk_Padding *paddingPtr) /* Requested inner border */ -{ - paddingPtr->left = paddingPtr->right = paddingPtr->top = paddingPtr->bottom - = *widthPtr = *heightPtr = 0; - - if (!InitializeElementRecord( - eclass, style, recordPtr, optionTable, tkwin, state)) - { - return; - } - eclass->specPtr->size( - eclass->clientData, eclass->elementRecord, - tkwin, widthPtr, heightPtr, paddingPtr); -} - -/* - * Ttk_DrawElement -- - * Draw the given widget element in a given drawable area. - */ - -void -Ttk_DrawElement( - Ttk_ElementClass *eclass, /* Element instance */ - Ttk_Style style, /* Style settings */ - char *recordPtr, /* The widget record. */ - Tk_OptionTable optionTable, /* Description of option table */ - Tk_Window tkwin, /* The widget window. */ - Drawable d, /* Where to draw element. */ - Ttk_Box b, /* Element area */ - Ttk_State state) /* Widget or element state flags. */ -{ - if (b.width <= 0 || b.height <= 0) - return; - if (!InitializeElementRecord( - eclass, style, recordPtr, optionTable, tkwin, state)) - { - return; - } - eclass->specPtr->draw( - eclass->clientData, eclass->elementRecord, - tkwin, d, b, state); -} - -/*------------------------------------------------------------------------ - * +++ 'style' command ensemble procedures. - */ - -/* - * TtkEnumerateHashTable -- - * Helper routine. Sets interp's result to the list of all keys - * in the hash table. - * - * Returns: TCL_OK. - * Side effects: Sets interp's result. - */ - -MODULE_SCOPE -int TtkEnumerateHashTable(Tcl_Interp *interp, Tcl_HashTable *ht) -{ - Tcl_HashSearch search; - Tcl_Obj *result = Tcl_NewListObj(0, NULL); - Tcl_HashEntry *entryPtr = Tcl_FirstHashEntry(ht, &search); - - while (entryPtr != NULL) { - Tcl_Obj *nameObj = Tcl_NewStringObj(Tcl_GetHashKey(ht, entryPtr),-1); - Tcl_ListObjAppendElement(interp, result, nameObj); - entryPtr = Tcl_NextHashEntry(&search); - } - - Tcl_SetObjResult(interp, result); - return TCL_OK; -} - -/* HashTableToDict -- - * Helper routine. Converts a TCL_STRING_KEYS Tcl_HashTable - * with Tcl_Obj * entries into a dictionary. - */ -static Tcl_Obj* HashTableToDict(Tcl_HashTable *ht) -{ - Tcl_HashSearch search; - Tcl_Obj *result = Tcl_NewListObj(0, NULL); - Tcl_HashEntry *entryPtr = Tcl_FirstHashEntry(ht, &search); - - while (entryPtr != NULL) { - Tcl_Obj *nameObj = Tcl_NewStringObj(Tcl_GetHashKey(ht, entryPtr),-1); - Tcl_Obj *valueObj = Tcl_GetHashValue(entryPtr); - Tcl_ListObjAppendElement(NULL, result, nameObj); - Tcl_ListObjAppendElement(NULL, result, valueObj); - entryPtr = Tcl_NextHashEntry(&search); - } - - return result; -} - -/* + style map $style ? -resource statemap ... ? - * - * Note that resource names are unconstrained; the Style - * doesn't know what resources individual elements may use. - */ -static int -StyleMapCmd( - ClientData clientData, /* Master StylePackageData pointer */ - Tcl_Interp *interp, /* Current interpreter */ - int objc, /* Number of arguments */ - Tcl_Obj *const objv[]) /* Argument objects */ -{ - StylePackageData *pkgPtr = clientData; - Ttk_Theme theme = pkgPtr->currentTheme; - const char *styleName; - Style *stylePtr; - int i; - - if (objc < 3) { -usage: - Tcl_WrongNumArgs(interp,2,objv,"style ?-option ?value...??"); - return TCL_ERROR; - } - - styleName = Tcl_GetString(objv[2]); - stylePtr = Ttk_GetStyle(theme, styleName); - - /* NOTE: StateMaps are actually Tcl_Obj *s, so HashTableToDict works - * for settingsTable. - */ - if (objc == 3) { /* style map $styleName */ - Tcl_SetObjResult(interp, HashTableToDict(&stylePtr->settingsTable)); - return TCL_OK; - } else if (objc == 4) { /* style map $styleName -option */ - const char *optionName = Tcl_GetString(objv[3]); - Tcl_HashEntry *entryPtr = - Tcl_FindHashEntry(&stylePtr->settingsTable, optionName); - if (entryPtr) { - Tcl_SetObjResult(interp, (Tcl_Obj*)Tcl_GetHashValue(entryPtr)); - } - return TCL_OK; - } else if (objc % 2 != 1) { - goto usage; - } - - for (i = 3; i < objc; i += 2) { - const char *optionName = Tcl_GetString(objv[i]); - Tcl_Obj *stateMap = objv[i+1]; - Tcl_HashEntry *entryPtr; - int newEntry; - - /* Make sure 'stateMap' is legal: - * (@@@ SHOULD: check for valid resource values as well, - * but we don't know what types they should be at this level.) - */ - if (!Ttk_GetStateMapFromObj(interp, stateMap)) - return TCL_ERROR; - - entryPtr = Tcl_CreateHashEntry( - &stylePtr->settingsTable,optionName,&newEntry); - - Tcl_IncrRefCount(stateMap); - if (!newEntry) { - Tcl_DecrRefCount((Tcl_Obj*)Tcl_GetHashValue(entryPtr)); - } - Tcl_SetHashValue(entryPtr, stateMap); - } - ThemeChanged(pkgPtr); - return TCL_OK; -} - -/* + style configure $style -option ?value... - */ -static int StyleConfigureCmd( - ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) -{ - StylePackageData *pkgPtr = clientData; - Ttk_Theme theme = pkgPtr->currentTheme; - const char *styleName; - Style *stylePtr; - int i; - - if (objc < 3) { -usage: - Tcl_WrongNumArgs(interp,2,objv,"style ?-option ?value...??"); - return TCL_ERROR; - } - - styleName = Tcl_GetString(objv[2]); - stylePtr = Ttk_GetStyle(theme, styleName); - - if (objc == 3) { /* style default $styleName */ - Tcl_SetObjResult(interp, HashTableToDict(&stylePtr->defaultsTable)); - return TCL_OK; - } else if (objc == 4) { /* style default $styleName -option */ - const char *optionName = Tcl_GetString(objv[3]); - Tcl_HashEntry *entryPtr = - Tcl_FindHashEntry(&stylePtr->defaultsTable, optionName); - if (entryPtr) { - Tcl_SetObjResult(interp, (Tcl_Obj*)Tcl_GetHashValue(entryPtr)); - } - return TCL_OK; - } else if (objc % 2 != 1) { - goto usage; - } - - for (i = 3; i < objc; i += 2) { - const char *optionName = Tcl_GetString(objv[i]); - Tcl_Obj *value = objv[i+1]; - Tcl_HashEntry *entryPtr; - int newEntry; - - entryPtr = Tcl_CreateHashEntry( - &stylePtr->defaultsTable,optionName,&newEntry); - - Tcl_IncrRefCount(value); - if (!newEntry) { - Tcl_DecrRefCount((Tcl_Obj*)Tcl_GetHashValue(entryPtr)); - } - Tcl_SetHashValue(entryPtr, value); - } - - ThemeChanged(pkgPtr); - return TCL_OK; -} - -/* + style lookup $style -option ?statespec? ?defaultValue? - */ -static int StyleLookupCmd( - ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) -{ - StylePackageData *pkgPtr = clientData; - Ttk_Theme theme = pkgPtr->currentTheme; - Ttk_Style style = NULL; - const char *optionName; - Ttk_State state = 0ul; - Tcl_Obj *result; - - if (objc < 4 || objc > 6) { - Tcl_WrongNumArgs(interp, 2, objv, "style -option ?state? ?default?"); - return TCL_ERROR; - } - - style = Ttk_GetStyle(theme, Tcl_GetString(objv[2])); - if (!style) { - return TCL_ERROR; - } - optionName = Tcl_GetString(objv[3]); - - if (objc >= 5) { - Ttk_StateSpec stateSpec; - /* @@@ SB: Ttk_GetStateFromObj(); 'offbits' spec is ignored */ - if (Ttk_GetStateSpecFromObj(interp, objv[4], &stateSpec) != TCL_OK) { - return TCL_ERROR; - } - state = stateSpec.onbits; - } - - result = Ttk_QueryStyle(style, NULL,NULL, optionName, state); - if (result == NULL && objc >= 6) { /* Use caller-supplied fallback */ - result = objv[5]; - } - - if (result) { - Tcl_SetObjResult(interp, result); - } - - return TCL_OK; -} - -static int StyleThemeCurrentCmd( - ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj * const objv[]) -{ - StylePackageData *pkgPtr = clientData; - Tcl_HashSearch search; - Tcl_HashEntry *entryPtr = NULL; - const char *name = NULL; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 3, objv, ""); - return TCL_ERROR; - } - - entryPtr = Tcl_FirstHashEntry(&pkgPtr->themeTable, &search); - while (entryPtr != NULL) { - Theme *ptr = Tcl_GetHashValue(entryPtr); - if (ptr == pkgPtr->currentTheme) { - name = Tcl_GetHashKey(&pkgPtr->themeTable, entryPtr); - break; - } - entryPtr = Tcl_NextHashEntry(&search); - } - - if (name == NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "error: failed to get theme name", -1)); - Tcl_SetErrorCode(interp, "TTK", "THEME", "NAMELESS", NULL); - return TCL_ERROR; - } - - Tcl_SetObjResult(interp, Tcl_NewStringObj(name, -1)); - return TCL_OK; -} - -/* + style theme create name ?-parent $theme? ?-settings { script }? - */ -static int StyleThemeCreateCmd( - ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) -{ - StylePackageData *pkgPtr = clientData; - static const char *optStrings[] = - { "-parent", "-settings", NULL }; - enum { OP_PARENT, OP_SETTINGS }; - Ttk_Theme parentTheme = pkgPtr->defaultTheme, newTheme; - Tcl_Obj *settingsScript = NULL; - const char *themeName; - int i; - - if (objc < 4 || objc % 2 != 0) { - Tcl_WrongNumArgs(interp, 3, objv, "name ?-option value ...?"); - return TCL_ERROR; - } - - themeName = Tcl_GetString(objv[3]); - - for (i=4; i < objc; i +=2) { - int option; - if (Tcl_GetIndexFromObjStruct(interp, objv[i], optStrings, - sizeof(char *), "option", 0, &option) != TCL_OK) - { - return TCL_ERROR; - } - - switch (option) { - case OP_PARENT: - parentTheme = LookupTheme( - interp, pkgPtr, Tcl_GetString(objv[i+1])); - if (!parentTheme) - return TCL_ERROR; - break; - case OP_SETTINGS: - settingsScript = objv[i+1]; - break; - } - } - - newTheme = Ttk_CreateTheme(interp, themeName, parentTheme); - if (!newTheme) { - return TCL_ERROR; - } - - /* - * Evaluate the -settings script, if supplied: - */ - if (settingsScript) { - Ttk_Theme oldTheme = pkgPtr->currentTheme; - int status; - - pkgPtr->currentTheme = newTheme; - status = Tcl_EvalObjEx(interp, settingsScript, 0); - pkgPtr->currentTheme = oldTheme; - return status; - } else { - return TCL_OK; - } -} - -/* + style theme names -- - * Return list of registered themes. - */ -static int StyleThemeNamesCmd( - ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) -{ - StylePackageData *pkgPtr = clientData; - return TtkEnumerateHashTable(interp, &pkgPtr->themeTable); -} - -/* + style theme settings $theme $script - * - * Temporarily sets the current theme to $themeName, - * evaluates $script, then restores the old theme. - */ -static int -StyleThemeSettingsCmd( - ClientData clientData, /* Master StylePackageData pointer */ - Tcl_Interp *interp, /* Current interpreter */ - int objc, /* Number of arguments */ - Tcl_Obj *const objv[]) /* Argument objects */ -{ - StylePackageData *pkgPtr = clientData; - Ttk_Theme oldTheme = pkgPtr->currentTheme; - Ttk_Theme newTheme; - int status; - - if (objc != 5) { - Tcl_WrongNumArgs(interp, 3, objv, "theme script"); - return TCL_ERROR; - } - - newTheme = LookupTheme(interp, pkgPtr, Tcl_GetString(objv[3])); - if (!newTheme) - return TCL_ERROR; - - pkgPtr->currentTheme = newTheme; - status = Tcl_EvalObjEx(interp, objv[4], 0); - pkgPtr->currentTheme = oldTheme; - - return status; -} - -/* + style element create name type ? ...args ? - */ -static int StyleElementCreateCmd( - ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) -{ - StylePackageData *pkgPtr = clientData; - Ttk_Theme theme = pkgPtr->currentTheme; - const char *elementName, *factoryName; - Tcl_HashEntry *entryPtr; - FactoryRec *recPtr; - - if (objc < 5) { - Tcl_WrongNumArgs(interp, 3, objv, "name type ?-option value ...?"); - return TCL_ERROR; - } - - elementName = Tcl_GetString(objv[3]); - factoryName = Tcl_GetString(objv[4]); - - entryPtr = Tcl_FindHashEntry(&pkgPtr->factoryTable, factoryName); - if (!entryPtr) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "No such element type %s", factoryName)); - Tcl_SetErrorCode(interp, "TTK", "LOOKUP", "ELEMENT_TYPE", factoryName, - NULL); - return TCL_ERROR; - } - - recPtr = Tcl_GetHashValue(entryPtr); - - return recPtr->factory(interp, recPtr->clientData, - theme, elementName, objc - 5, objv + 5); -} - -/* + style element names -- - * Return a list of elements defined in the current theme. - */ -static int StyleElementNamesCmd( - ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) -{ - StylePackageData *pkgPtr = clientData; - Ttk_Theme theme = pkgPtr->currentTheme; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 3, objv, NULL); - return TCL_ERROR; - } - return TtkEnumerateHashTable(interp, &theme->elementTable); -} - -/* + style element options $element -- - * Return list of element options for specified element - */ -static int StyleElementOptionsCmd( - ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) -{ - StylePackageData *pkgPtr = clientData; - Ttk_Theme theme = pkgPtr->currentTheme; - const char *elementName; - Ttk_ElementClass *elementClass; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 3, objv, "element"); - return TCL_ERROR; - } - - elementName = Tcl_GetString(objv[3]); - elementClass = Ttk_GetElement(theme, elementName); - if (elementClass) { - Ttk_ElementSpec *specPtr = elementClass->specPtr; - Ttk_ElementOptionSpec *option = specPtr->options; - Tcl_Obj *result = Tcl_NewListObj(0,0); - - while (option->optionName) { - Tcl_ListObjAppendElement( - interp, result, Tcl_NewStringObj(option->optionName,-1)); - ++option; - } - - Tcl_SetObjResult(interp, result); - return TCL_OK; - } - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "element %s not found", elementName)); - Tcl_SetErrorCode(interp, "TTK", "LOOKUP", "ELEMENT", elementName, NULL); - return TCL_ERROR; -} - -/* + style layout name ?spec? - */ -static int StyleLayoutCmd( - ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) -{ - StylePackageData *pkgPtr = clientData; - Ttk_Theme theme = pkgPtr->currentTheme; - const char *layoutName; - Ttk_LayoutTemplate layoutTemplate; - - if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 2, objv, "name ?spec?"); - return TCL_ERROR; - } - - layoutName = Tcl_GetString(objv[2]); - - if (objc == 3) { - layoutTemplate = Ttk_FindLayoutTemplate(theme, layoutName); - if (!layoutTemplate) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Layout %s not found", layoutName)); - Tcl_SetErrorCode(interp, "TTK", "LOOKUP", "LAYOUT", layoutName, - NULL); - return TCL_ERROR; - } - Tcl_SetObjResult(interp, Ttk_UnparseLayoutTemplate(layoutTemplate)); - } else { - layoutTemplate = Ttk_ParseLayoutTemplate(interp, objv[3]); - if (!layoutTemplate) { - return TCL_ERROR; - } - Ttk_RegisterLayoutTemplate(theme, layoutName, layoutTemplate); - ThemeChanged(pkgPtr); - } - return TCL_OK; -} - -/* + style theme use $theme -- - * Sets the current theme to $theme - */ -static int -StyleThemeUseCmd( - ClientData clientData, /* Master StylePackageData pointer */ - Tcl_Interp *interp, /* Current interpreter */ - int objc, /* Number of arguments */ - Tcl_Obj *const objv[]) /* Argument objects */ -{ - StylePackageData *pkgPtr = clientData; - Ttk_Theme theme; - - if (objc < 3 || objc > 4) { - Tcl_WrongNumArgs(interp, 3, objv, "?theme?"); - return TCL_ERROR; - } - - if (objc == 3) { - return StyleThemeCurrentCmd(clientData, interp, objc, objv); - } - - theme = LookupTheme(interp, pkgPtr, Tcl_GetString(objv[3])); - if (!theme) { - return TCL_ERROR; - } - - return Ttk_UseTheme(interp, theme); -} - -/* - * StyleObjCmd -- - * Implementation of the [style] command. - */ - -static const Ttk_Ensemble StyleThemeEnsemble[] = { - { "create", StyleThemeCreateCmd, 0 }, - { "names", StyleThemeNamesCmd, 0 }, - { "settings", StyleThemeSettingsCmd, 0 }, - { "use", StyleThemeUseCmd, 0 }, - { NULL, 0, 0 } -}; - -static const Ttk_Ensemble StyleElementEnsemble[] = { - { "create", StyleElementCreateCmd, 0 }, - { "names", StyleElementNamesCmd, 0 }, - { "options", StyleElementOptionsCmd, 0 }, - { NULL, 0, 0 } -}; - -static const Ttk_Ensemble StyleEnsemble[] = { - { "configure", StyleConfigureCmd, 0 }, - { "map", StyleMapCmd, 0 }, - { "lookup", StyleLookupCmd, 0 }, - { "layout", StyleLayoutCmd, 0 }, - { "theme", 0, StyleThemeEnsemble }, - { "element", 0, StyleElementEnsemble }, - { NULL, 0, 0 } -}; - -static int -StyleObjCmd( - ClientData clientData, /* Master StylePackageData pointer */ - Tcl_Interp *interp, /* Current interpreter */ - int objc, /* Number of arguments */ - Tcl_Obj *const objv[]) /* Argument objects */ -{ - return Ttk_InvokeEnsemble(StyleEnsemble, 1, clientData,interp,objc,objv); -} - -MODULE_SCOPE -int Ttk_InvokeEnsemble( /* Run an ensemble command */ - const Ttk_Ensemble *ensemble, int cmdIndex, - void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) -{ - while (cmdIndex < objc) { - int index; - if (Tcl_GetIndexFromObjStruct(interp, - objv[cmdIndex], ensemble, sizeof(ensemble[0]), - "command", 0, &index) - != TCL_OK) - { - return TCL_ERROR; - } - - if (ensemble[index].command) { - return ensemble[index].command(clientData, interp, objc, objv); - } - ensemble = ensemble[index].ensemble; - ++cmdIndex; - } - Tcl_WrongNumArgs(interp, cmdIndex, objv, "option ?arg ...?"); - return TCL_ERROR; -} - -/* - * Ttk_StylePkgInit -- - * Initializes all the structures that are used by the style - * package on a per-interp basis. - */ - -void Ttk_StylePkgInit(Tcl_Interp *interp) -{ - Tcl_Namespace *nsPtr; - - StylePackageData *pkgPtr = ckalloc(sizeof(StylePackageData)); - - pkgPtr->interp = interp; - Tcl_InitHashTable(&pkgPtr->themeTable, TCL_STRING_KEYS); - Tcl_InitHashTable(&pkgPtr->factoryTable, TCL_STRING_KEYS); - pkgPtr->cleanupList = NULL; - pkgPtr->cache = Ttk_CreateResourceCache(interp); - pkgPtr->themeChangePending = 0; - - Tcl_SetAssocData(interp, PKG_ASSOC_KEY, Ttk_StylePkgFree, pkgPtr); - - /* - * Create the default system theme: - * - * pkgPtr->defaultTheme must be initialized to 0 before - * calling Ttk_CreateTheme for the first time, since it's used - * as the parent theme. - */ - pkgPtr->defaultTheme = 0; - pkgPtr->defaultTheme = pkgPtr->currentTheme = - Ttk_CreateTheme(interp, "default", NULL); - - /* - * Register null element, used as a last-resort fallback: - */ - Ttk_RegisterElement(interp, pkgPtr->defaultTheme, "", &ttkNullElementSpec, 0); - - /* - * Register commands: - */ - Tcl_CreateObjCommand(interp, "::ttk::style", StyleObjCmd, pkgPtr, 0); - - nsPtr = Tcl_FindNamespace(interp, "::ttk", NULL, TCL_LEAVE_ERR_MSG); - Tcl_Export(interp, nsPtr, "style", 0 /* dontResetList */); - - Ttk_RegisterElementFactory(interp, "from", Ttk_CloneElement, 0); -} - -/*EOF*/ |