summaryrefslogtreecommitdiffstats
path: root/generic/ttk/ttkTheme.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/ttk/ttkTheme.c')
-rw-r--r--generic/ttk/ttkTheme.c1737
1 files changed, 1737 insertions, 0 deletions
diff --git a/generic/ttk/ttkTheme.c b/generic/ttk/ttkTheme.c
new file mode 100644
index 0000000..5095487
--- /dev/null
+++ b/generic/ttk/ttkTheme.c
@@ -0,0 +1,1737 @@
+/*
+ * 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 = (Style*)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((ClientData)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 = (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 =
+ (Ttk_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 = (Tcl_Obj**)
+ 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((ClientData)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((ClientData)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 = (Theme*)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((ClientData)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((ClientData)cleanup);
+ cleanup = next;
+ }
+
+ ckfree((ClientData)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 = (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;
+
+ if (Tcl_GlobalEval(pkgPtr->interp, ThemeChangedScript) != TCL_OK) {
+ Tcl_BackgroundError(pkgPtr->interp);
+ }
+ 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_ResetResult(interp);
+ Tcl_AppendResult(interp, "Theme ", name, " already 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_ResetResult(interp);
+ Tcl_AppendResult(interp, "theme \"", name, "\" doesn't exist", 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 = (FactoryRec*)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_ResetResult(interp);
+ Tcl_AppendResult(interp, "Internal error: Ttk_RegisterElement (",
+ name, "): invalid version",
+ NULL);
+ }
+ return 0;
+ }
+
+ entryPtr = Tcl_CreateHashEntry(&theme->elementTable, name, &newEntry);
+ if (!newEntry) {
+ if (interp) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, "Duplicate element ", name, 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));
+ 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_GetIndexFromObj(
+ interp, objv[i], optStrings, "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_AppendResult(interp, "No such 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_AppendResult(interp, "element ", elementName, " not found", 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_AppendResult(interp, "Layout ", layoutName, " not found", 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 = (StylePackageData *)
+ 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*/