/* * 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. * * $Id: ttkTheme.c,v 1.23 2010/03/28 21:43:25 jenglish Exp $ */ #include #include #include #include #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 <>). */ 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 <> 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; ioffset); 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", (Tcl_Namespace *) NULL, TCL_LEAVE_ERR_MSG); Tcl_Export(interp, nsPtr, "style", 0 /* dontResetList */); Ttk_RegisterElementFactory(interp, "from", Ttk_CloneElement, 0); } /*EOF*/