ADDED doc/tko.3.md Index: doc/tko.3.md ================================================================== --- /dev/null +++ doc/tko.3.md @@ -0,0 +1,213 @@ +# tkoWidget(3) -- oo class like widgets + +* [NAME](#NAME) +* [SYNOPSIS](#SYNOPSIS) +* [ARGUMENTS](#ARGUMENTS) +* [DESCRIPTION](#DESCRIPTION) +* [SEE ALSO](#SEE-ALSO) +* [KEYWORDS](#KEYWORDS) +* [COPYRIGHT](#COPYRIGHT) + + +## NAME + +Tko\_WidgetClassDefine, +Tko\_WidgetCreate, +Tko\_WidgetDestroy, +Tko\_WidgetClientData, +Tko\_WidgetOptionGet, +Tko\_WidgetOptionSet, + + +## SYNOPSIS + +**#include "tkoWidget.h"** + +int +**Tko\_WidgetClassDefine**(*interp,classname,methods,options*) +int +**Tko\_WidgetCreate**(*clientdata,interp,object,createmode,arglist*) +void +**Tko\_WidgetDestroy**(*context*) +ClientData +**Tko\_WidgetClientData**(*context*) +Tcl\_Obj \* +**Tko\_WidgetOptionGet**(*widget,option*) +int +**Tko\_WidgetOptionSet**(*widget,option,value*) + + +## ARGUMENTS + +| Tcl\_Interp **\*interp** | Used interpreter. +| Tcl\_Obj **\*classname** |Oo class name of widget. +| const Tcl\_MethodType **\*methods** | This array defines class methods to create. For creation methods see [Tcl\_NewMethod] manpage. If the method name of the first array entry is not NULL it will be used as **constructor**, if the second method name is not NULL it used as **destructor**. Then follow public methods until an entry with an method name equal NULL comes. Then follow private methods until an entry with an method name equal NULL comes. +| const Tko\_WidgetOptionDefine **\*options** | This array contain option definitions. +| Tcl\_Object **object** | This is the current object reference. +| Tko_WidgetCreateMode **createmode** | When =1 then create a toplevel otherwise a frame window. +| Tcl\_Obj **arglist** | Argument list of constructor call. +| ClientData **cientdata** | Pointer to widget structure. First part in this struct is Tko\_Widget. It +| Tcl\_ObjectContext **context** | Context of method calls. +| Tcl\_Obj **\*option** | The name of the used option. +| Tcl\_Obj **\*value** | New value of the given option. + + +## DESCRIPTION + +The **Tko\_WidgetClassDefine** function create a new tko widget class of *classname*. The function create the class add common methods (cget, configure, \_tko\_configure) and then add given methods and options. + +The **Tko\_WidgetCreate** function create a new window. The *clientdata* should be *ckalloc*ed in the widget constructor. The function add the given *clientdata* to the object metadata. The function should be called in a C widget constructor. + +The **Tko\_WidgetDestroy** function clears all internal widget data. The function also arrange the *ckfree* of the *clientdata*. + +The **Tko\_WidgetClientData** should be used from inside widget methods to get the widget structure data given in the **Tko\_WidgetCreate** function. + +The **Tko\_WidgetOptionGet** function returns the current value of the given option. + +The **Tko\_WidgetOptionSet** function set the given *option* to the new given *value*. + +### Enum: `Tko_WidgetOptionType` + +Suported enum type in the **Tko\_WidgetOptionDefine** definition. As comment is the type of the address provided in the **Tko\_WidgetOptionDefine** definition. + + typedef enum Tko\_WidgetOptionType { + TKO_SET_CLASS = 1, /* (Tcl_Obj **)address */ + TKO_SET_VISUAL, /* (Tcl_Obj **)address */ + TKO_SET_COLORMAP, /* (Tcl_Obj **)address */ + TKO_SET_USE, /* (Tcl_Obj **)address */ + TKO_SET_CONTAINER, /* (int *)address */ + TKO_SET_TCLOBJ, /* (Tcl_Obj **)address */ + TKO_SET_XCOLOR, /* (Xcolor **)address */ + TKO_SET_3DBORDER, /* (Tk_3DBorder *)address */ + TKO_SET_PIXEL, /* (int *)address */ + TKO_SET_PIXELNONEGATIV, /* (int *)address */ + TKO_SET_PIXELPOSITIV, /* (int *)address */ + TKO_SET_DOUBLE, /* (double *)address */ + TKO_SET_BOOLEAN, /* (int *)address */ + TKO_SET_CURSOR, /* (Tk_Cursor *)address */ + TKO_SET_INT, /* (int *)address */ + TKO_SET_RELIEF, /* (int *)address */ + TKO_SET_ANCHOR, /* (int *)address */ + TKO_SET_WINDOW, /* (Tk_Window *)address */ + TKO_SET_FONT, /* (Tk_Font *)address */ + TKO_SET_STRING, /* (char **)address */ + TKO_SET_SCROLLREGION, /* (int *[4])address */ + TKO_SET_JUSTIFY /* (Tk_Justify *)address */ + } Tko\_WidgetOptionType; + +### Enum: `Tko_WidgetCreateMode` + +Supported values in **Tko\_WdigetCreate()** function call. + + typedef enum Tko_WidgetCreateMode { + TKO_CREATE_WIDGET, /* Create new widget */ + TKO_CREATE_TOPLEVEL, /* Create new toplevel widget */ + TKO_CREATE_CLASS, /* See "tko initclass" */ + TKO_CREATE_WRAP /* See "tko initwrap" */ + } Tko_WidgetCreateMode; + +### Struct: `Tko_WidgetOptionDefine` + +Widget definition data used in class. +An option set method "-option" is created in the following order: + - "option"=NULL indicate the end of a list of option definitions. + - If "method" is given it will be used as option set method. + - If "type" is greater 0 a common option set method will be used. + In this case "offset" are used as offset in the widget structure. + + typedef struct Tko_WidgetOptionDefine { + const char *option; /* Name of option. Starts with "-" minus sign */ + const char *dbname; /* Option DB name or synonym option if dbclass is NULL */ + const char *dbclass; /* Option DB class name or NULL for synonym options. */ + const char *defvalue; /* Default value. */ + int flags; /* bit array of TKO_OPTION_* values to configure option behaviour */ + Tcl_MethodCallProc *method; /* If not NULL it is the function name of the -option method */ + Tko_WidgetOptionType type; /* if greater 0 then option type used in common option set method */ + int offset; /* offset in meta data struct */ + } Tko_WidgetOptionDefine; + #define TKO_OPTION_READONLY 0x1 /* option is only setable at creation time */ + +### Struct: `Tko_Widget` + +Widget structure data used in objects. +These structure will be filled in the **Tko\_WidgetCreate** call and cleared in +the **Tko\_WidgetDestroy** call. Widget methods should check the value of *tkWin* on NULL before using it. + + typedef struct Tko_Widget { + Tk_Window tkWin; /* Window that embodies the widget. NULL means + * that the window has been destroyed but the + * data structures haven't yet been cleaned + * up.*/ + Display *display; /* Display containing widget. Used, among + * other things, so that resources can be + * freed even after tkwin has gone away. */ + Tcl_Interp *interp; /* Interpreter associated with widget. */ + Tcl_Command widgetCmd; /* Token for command. */ + Tcl_Object object; /* our own object */ + Tcl_Obj *myCmd; /* Objects "my" command. Needed to call internal methods. */ + Tcl_Obj *optionsArray; /* Name of option array variable */ + Tcl_HashTable *optionsTable; /* Hash table containing all used options */ + } Tko_Widget; + + + +### EXAMPLES + + static Tko_WidgetOptionDefine myOptions[] = { + /* + * Readonly option, only setable on creation time. + * Use of internal standard option setting function. + */ + {"-class","class","Class","TkoFrame",TKO_OPTION_READONLY, + NULL,NULL,TKO_SET_CLASS,NULL,0}, + /* + * Option value in structure have NULL value when option is empty. + * Use of internal standard option setting function. + */ + {"-background","background","Background",DEF_FRAME_BG_COLOR,TKO_OPTION_NULL, + NULL,NULL,TKO_SET_3DBORDER,&frameMeta,offsetof(tkoFrame, border)}, + /* + * Use own provided oo method to set option value. + */ + {"-backgroundimage","backgroundImage","BackgroundImage",DEF_FRAME_BG_IMAGE,0, + NULL,FrameMethod_backgroundimage,0,NULL,0}, + /* + * Synonym option definition. + */ + {"-bg","-background",NULL,NULL,0,NULL,NULL,0,NULL,0}, + /* + * Indicate end of options in array. + */ + {NULL,NULL,NULL,NULL,0,NULL,NULL,0,NULL,0} + }; + +For detailed examples see also the implementation of **tko::toplevel**, **tko::frame** and **tko::labelframe** widgets in file generic/tko/tkoFrame.c. + + +## SEE ALSO + +[frame][], [labelframe][], [toplevel][], [oo::class][] + + +## KEYWORDS + +oo widget method option + + +## COPYRIGHT + +© 2019- René Zaumseil + +BSD style license. + +[options]: options.htm +[frame]: frame.htm +[labelframe]: labelframe.htm +[toplevel]: toplevel.htm +[oo::class]: class.htm +[graph]: graph.htm +[path]: path.htm +[Tkpath]: +[Rbc]: + + ADDED doc/tko.n.md Index: doc/tko.n.md ================================================================== --- /dev/null +++ doc/tko.n.md @@ -0,0 +1,339 @@ +# tko(n) -- oo class like widgets + +* [SYNOPSIS](#SYNOPSIS) +* [TKO STANDARD OPTIONS](#TKO-STANDARD-OPTIONS) + [-class, class, Class](#-class) + [-screen, screen, Screen](#-screen) +* [DESCRIPTION](#DESCRIPTION) +* [PUBLIC METHODS](#PUBLIC-METHODS) +* [PRIVATE METHODS](#PRIVATE-METHODS) +* [OPTIONS](#OPTIONS) +* [EXAMPLES](#EXAMPLES) +* [SEE ALSO](#SEE-ALSO) +* [KEYWORDS](#KEYWORDS) +* [COPYRIGHT](#COPYRIGHT) + + +## SYNOPSIS + +### Tko widgets + +**::tko::toplevel** *pathName ?option value? ..* + +**::tko::frame** *pathName ?option value? ..* + +**::tko::labelframe** *pathName ?option value? ..* + +### Class functions + +**::tko initclass** + +**::tko initfrom** *tkoclass* + +**::tko initwrap** *widget readonlyoptionlist methodlist* + +**::tko eventoption** + +**::tko optiondef** *classname ?-option definitionlist? .. ?body?* + +**::tko optiondel** *classname ?-option? ..* + +**::tko optionget** *classname ?-option? ..* + +**::tko optionhide** *classname ?-option? ..* + +**::tko optionshow** *classname ?-option? ..* + +### Widget methods + +**my \_tko optionadd** *-option definitionlist ?body?* + +**my \_tko optiondel** *-option* .. + +**my \_tko optionhide** *-option* .. + +**my \_tko optionshow** *-option* .. + + +## TKO STANDARD OPTIONS + + +Command-Line Name: **-class** +Database Name: **class** +Database Class: **Class** + +> Define class for use in getting values from option database. Can only be set on widget creation time. The option should be the first option in the option definition list because it is needed to get other option values from the option database. Only the **-screen** option can precede it. + + +Command-Line Name: **-screen** +Database Name: **screen** +Database Class: **Screen** + +> Affect creation of underlying widget structure. If given the created widget will be a toplevel widget. The option should be the very first option of an widget to be recognised. + + +## DESCRIPTION + +### Option definitionlist + +In the *definitionlist* description below an entry with name *flags* can contain a combination of the following letters: + + - "r" the option is readonly and can only be set on creation + - "h" The option is hidden from use in **cget** and **configure** methods. + +The *definitionlist* can have one of the following forms: + + - *{-synonym flags}* + +> Description of an synonym option. When *-option* is set then instead the provided *-synonym* option will be set. + + - *{dbname dbclass default flags}* + +> Description of an option. +If *dbname* or *dbclass* is not empty then the values will be used to search for an default option value in the option database. +The search will need a **Tk\_Window** and therefore this definition can only be used in an widget class. +If both value are empty then the option definition can be used in an normal class create with **tko initclass**. +*default* is the default value if no value can be found in the option database. + +### Function **::tko** + +**::tko initclass** + +> The function will create public **constructor**, **destructor**, **cget** and **configure** methods and private **_tko** and **_tko_configure** methods in the current class. + +> The function can be used to add **cget** and **configure** functionality to an normal oo class. +No additional functionality is added. + +> The function should be called only once inside the "oo::class create" script. +When called the list of used options will be cleared. + +**::tko initfrom** *tkoclass* + +> This function will provide the necessary initialization of an oo class as tko widget. +The argument *tkoclass* should be an **tko** widget class. +The class *tkoclass* will be the superclass of the current widget and all options of *tkoclass* will be added to our new class. + +> If you create your own **constructor**, **destructor**, **cget** or **configure** methods you need to call **next** inside these function to call the function of the *tkoclass* superclass. + +> The function should be called only once inside the "oo::class create" script. +When called the list of used options will be cleared. + +**::tko initwrap** *widget readonlyoptionlist methodlist* + +> This function will wrap an existing normal tk widget as an tko widget class. +The argumen *widget* is the name of the normal tk widget. +The argument *readonlyoptionlist* is a list of all readonly options of the given *widget*. +The argument *methodlist* is a list of methods to link to the wrapped *widget*. + +> The function will create public **constructor**, **destructor**, **cget** and **configure** methods and private **_tko** and **_tko_configure** methods in the current class. + +> The function should be called only once inside the "oo::class create" script. +When called the list of used options will be cleared. + +**::tko eventoption** + +> This option will send an <> virtual event to all widgets. +If a option value was set using the option database then the value of this option will updated with the current value of the option database. +The option database can so be used as a style source. + +**::tko optiondef** *classname ?-option definitionlist? .. ?body?* + +> The function will add or replace all given *-option definitionlist* pairs to the given *classname*. If an additional ?body? argument is given it will be used to create the *-option* method of the last given *-option* in *classname* + +**::tko optiondel** *::classname ?-option? ..* + +> The function will remove the given options from the defined class options of the given *::classname*. If no option is given then all existing options will be removed. + +**::tko optionget** *::classname ?-option? ..* + +> This function will return a list of *-option definitionlist* pairs ready for use in the **::tko optiondef** command. +The list consist of the specified options or all options if there are no options given. +THe option will be read from the fully qualified ?::classname? definitions. + +**::tko optionhide** *::classname ?-option ..* + +> Hide the given options from the use in **cget** and **configure** methods. If no options are given then return the list of all hidden options. + +**::tko optionshow** *::classname ?-option ..* + +> Unhide the given options from the use in **cget** and **configure** methods. If no options are given then return the list of all useable options. + + +### Widget **::tko::toplevel** + +These class contain the functionality of the [toplevel][] widget command. + + +### Widget **::tko::frame** + +These class contain the functionality of the [frame][] widget command. + + +### Widget **::tko::labelframe** + +These class contain the functionality of the [labelframe][] widget command. + + +## PUBLIC METHODS + +Widget methods can be dynamically added and removed at class or object level. + +**NOTE** Do not change *tkoClass*'s behaviour. Instead create your own class and modify it to your need! Or change created widget objects behaviour. + + +**cget** *-option* + +> Return the current value of the given *option*. + + +**configure** + +> The method will return a sorted list of all configuration options. + +**configure** *-option* + +> Return value of given option. + +**configure** *-option value* .. + +> Use given *-option vlaue* pairs to set options. + + +## PRIVATE METHODS + + +**my \_tko optionadd** *-option definitionlist ?body?* + +> Add a new option in the current object. The meaning of the *definitionlist* argument is the same as in the **::tko optionset** command. +The function will only add new options. +It is not possible to change object options. + +**my \_tko optiondel** *-option* .. + +> Delete the given option and unset the entry in the tko array variable. The created *-option* method's are not deleted. This is the task of the caller. + +**my \_tko optionhide** *-option* .. + +> If no *-option* is given return a list of all not configure'able options. Otherwise hide all of the given options. + +**my \_tko optionshow** *-option* .. + +> If no *-option* is given return a list of all configure'able options. Otherwise make all of the given options configure'able. + + +**my \_tko\_configure** + +> This is an virtual method of the *tkoClass* widgets. This method will be called at the end of each **configure** *-option value ..* call. It can be implemented in each class to make necessary changes. If it is implemented it should also call **next** to notify underlying classes. + + +## OPTIONS + +Widget option values are saved in an option array **tko**. The option name is the field name in the array. Additionally is an field "**.**" containing the tk widget path name of the widget. + +Widget options can be dynamically added and removed at class or object level. +It is possible to hide and unhide options. + + +## EXAMPLES + + # + # Configurable object + # + oo::class create A { + ::tko initclass + } + A create a1 + a1 configure ==> + + # Add class option + ::tko optiondef A -o1 {o1 O1 v1 {}} {set tko(-o1) x} + A create a2 + a2 configure + ==> {-o1 o1 O1 v1 v1} + + # Add object option + oo::define A method mycmd {args} {my {*}$args} + a2 mycmd _tko optionadd -o2 {o2 O2 v2 {}} {variable tko; set tko(-o2) x} + a2 configure + ==> {-o1 o1 O1 v1 v1} {-o2 o2 O2 v2 x} + + # + # Wrap an existing widget + # + oo::class create B { + ::tko initwrap frame {-class -container -colormap -visual} {} + } + B .b + lindex [.b configure] 0 + ==> {-background background Background SystemButtonFace SystemButtonFace} + + # + # Create a new widget class. + # + oo::class create C { + ::tko initfrom ::tko::frame + constructor {args} {next {*}$args} + destructor {next} + method mycmd {args} {my {*}$args} + } + + # Hide all inherited frame options + ::tko optionhide C {*}[::tko optionhide C] + ::tko optionshow C + ==> -class -visual -colormap -container -borderwidth ... + C .c + .c configure + ==> + + # Add a new option + oo::define C method -o1 {} {puts $tko(-o1)} + ::tko optiondef C -o1 {o1 O1 v1 {}} + ::tko optionhide C + ==> -o1 + + # Add another option + ::tko optiondef C -o2 {o2 O2 v2 {}} {puts $tko(-o2)} + ::tko optionhide C + ==> -o1 -o2 + + # Add options at object level: + C .c1 + .c1 mycmd _tko optionadd -o3 {o3 O3 v3 {}} {my variable tko; puts $tko(-o3)} + .c1 configure + ==> {-o1 o1 O1 v1 v1} {-o2 o2 O2 v2 v2} {-o3 o3 O3 v3 v3} + + # Show all frame options again + .c1 mycmd _tko optionshow {*}[.c1 mycmd _tko optionshow] + llength [.c1 configure] + ==> 24 + + # Intercept options + oo::define C method -width {} { + puts "[my cget -width]->$tko(-width)->[set tko(-width) 100]" + } + .c1 configure -width 1 + ==> 0->1->100 + + +## SEE ALSO + +[frame][], [labelframe][], [toplevel][], [oo::class][] + + +## KEYWORDS + +oo widget method option + + +## COPYRIGHT + +© 2019- René Zaumseil + +BSD style license. + +[options]: options.htm +[frame]: frame.htm +[labelframe]: labelframe.htm +[toplevel]: toplevel.htm +[oo::class]: class.htm + Index: generic/tkInt.h ================================================================== --- generic/tkInt.h +++ generic/tkInt.h @@ -1191,10 +1191,16 @@ * Themed widget set init function: */ MODULE_SCOPE int Ttk_Init(Tcl_Interp *interp); +/* + * Tko widget set init function: + */ + +MODULE_SCOPE int Tko_Init(Tcl_Interp *interp); + /* * Internal functions shared among Tk modules but not exported to the outside * world: */ Index: generic/tkWindow.c ================================================================== --- generic/tkWindow.c +++ generic/tkWindow.c @@ -3437,10 +3437,19 @@ code = Ttk_Init(interp); if (code != TCL_OK) { goto done; } + + /* + * Initialized the tko widget set + */ + + code = Tko_Init(interp); + if (code != TCL_OK) { + goto done; + } /* * Invoke platform-specific initialization. Unlock mutex before entering * TkpInit, as that may run through the Tk_Init routine again for the * console window interpreter. ADDED generic/tko/tkoFrame.c Index: generic/tko/tkoFrame.c ================================================================== --- /dev/null +++ generic/tko/tkoFrame.c @@ -0,0 +1,1986 @@ +/* + * tkoFrame.c -- + * + * This module implements "frame", "labelframe" and "toplevel" widgets + * for the Tk toolkit. Frames are windows with a background color and + * possibly a 3-D effect, but not much else in the way of attributes. + * + * Copyright (c) 1990-1994 The Regents of the University of California. + * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 2019 Rene Zaumseil + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tkoWidget.h" + + /* + * The following enum is used to define the type of the frame. + */ +enum FrameType { + TYPE_FRAME, TYPE_TOPLEVEL, TYPE_LABELFRAME +}; + +/* + * tkoFrame -- + * + * A data structure of the following type is kept for each + * frame that currently exists for this process. + * + * ATTENTION!!! + * tkWinWM.c will call TkInstallFromMenu() from file tkFrame.c for toplevels. + * Inside these function a struct Frame and memeber menuName will be used. + * We noe have to ensure that our structure has the same form as Frame. + * Therefore we place some dummy arguments in the structure. + */ +typedef struct tkoFrame { + Tko_Widget widget; + enum FrameType type; /* Type of widget, such as TYPE_FRAME. */ + char *dummy1; + char *menuName; /* Textual description of menu to use for + * menubar. Malloc-ed, may be NULL. */ + Colormap colormap; /* If not None, identifies a colormap + * allocated for this window, which must be + * freed when the window is deleted. */ + Tk_3DBorder border; /* Structure used to draw 3-D border and + * background. NULL means no background or + * border. */ + int borderWidth; /* Width of 3-D border (if any). */ + int relief; /* 3-d effect: TK_RELIEF_RAISED etc. */ + int highlightWidth; /* Width in pixels of highlight to draw around + * widget when it has the focus. 0 means don't + * draw a highlight. */ + XColor *highlightBgColorPtr; + /* Color for drawing traversal highlight area + * when highlight is off. */ + XColor *highlightColorPtr; /* Color for drawing traversal highlight. */ + int width; /* Width to request for window. <= 0 means + * don't request any size. */ + int height; /* Height to request for window. <= 0 means + * don't request any size. */ + Tk_Cursor cursor; /* Current cursor for window, or None. */ + Tk_Window tkWinCreate; + char *dummy2; + int isContainer; /* 1 means this window is a container, 0 means + * that it isn't. */ + Tcl_Obj *useThis; /* If the window is embedded, this points to + * the name of the window in which it is + * embedded (malloc'ed). For non-embedded + * windows this is NULL. */ + int flags; /* Various flags; see below for + * definitions. */ + int padX; /* Integer value corresponding to padXPtr. */ + int padY; /* Integer value corresponding to padYPtr. */ + unsigned int mask; + Tk_Image bgimg; /* Derived from -backgroundimage by calling + * Tk_GetImage, or NULL. */ + int tile; /* Whether to tile the bgimg. */ +#ifndef TK_NO_DOUBLE_BUFFERING + GC copyGC; /* GC for copying when double-buffering. */ +#endif /* TK_NO_DOUBLE_BUFFERING */ +} tkoFrame; + +/* + * tkoLabelframe -- + * + * A data structure of the following type is kept for each labelframe widget + * managed by this file: + */ +typedef struct tkoLabelframe { + tkoFrame frame; /* A pointer to the generic frame structure. + * This must be the first element of the + * tkoLabelframe. */ + /* + * tkoLabelframe specific configuration settings. + */ + Tcl_Obj *textPtr; /* Value of -text option: specifies text to + * display in button. */ + Tk_Font tkfont; /* Value of -font option: specifies font to + * use for display text. */ + XColor *textColorPtr; /* Value of -fg option: specifies foreground + * color in normal mode. */ + int labelAnchor; /* Value of -labelanchor option: specifies + * where to place the label. */ + Tk_Window labelWin; /* Value of -labelwidget option: Window to use + * as label for the frame. */ + /* + * tkoLabelframe specific fields for use with configuration settings above. + */ + GC textGC; /* GC for drawing text in normal mode. */ + Tk_TextLayout textLayout; /* Stored text layout information. */ + XRectangle labelBox; /* The label's actual size and position. */ + int labelReqWidth; /* The label's requested width. */ + int labelReqHeight; /* The label's requested height. */ + int labelTextX, labelTextY; /* Position of the text to be drawn. */ +} tkoLabelframe; + +/* + * The following macros define how many extra pixels to leave around a label's + * text. + */ +#define LABELSPACING 1 +#define LABELMARGIN 4 + + /* + * Flag bits for frames: + * + * REDRAW_PENDING: Non-zero means a DoWhenIdle handler has + * already been queued to redraw this window. + * GOT_FOCUS: Non-zero means this widget currently has the + * input focus. + */ +#define REDRAW_PENDING 1 +#define GOT_FOCUS 4 + + /* + * The following enum is used to define a type for the -labelanchor option of + * the Labelframe widget. These values are used as indices into the string + * table below. + */ +enum labelanchor { + LABELANCHOR_E, LABELANCHOR_EN, LABELANCHOR_ES, + LABELANCHOR_N, LABELANCHOR_NE, LABELANCHOR_NW, + LABELANCHOR_S, LABELANCHOR_SE, LABELANCHOR_SW, + LABELANCHOR_W, LABELANCHOR_WN, LABELANCHOR_WS +}; + +/* +* Methods +*/ +static int FrameConstructorFrame( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); +static int FrameConstructorLabelframe( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); +static int FrameConstructorToplevel( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); +static int FrameConstructor( + enum FrameType type, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); +static int FrameDestructor( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); +static int FrameMethod_tko_configure( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); +static int FrameMethod_labelanchor( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); +static int FrameMethod_labelwidget( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); +static int FrameMethod_backgroundimage( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); +static int FrameMethod_menu( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); + +/* + * Functions + */ +static void FrameComputeGeometry( + tkoFrame * frame); +static void FrameDisplay( + ClientData clientData); +static void FrameDrawBackground( + Tk_Window tkwin, + Pixmap pixmap, + int highlightWidth, + int borderWidth, + Tk_Image bgimg, + int bgtile); +static void FrameBgImageProc( + ClientData clientData, + int x, + int y, + int width, + int height, + int imgWidth, + int imgHeight); +static void FrameEventProc( + ClientData clientData, + XEvent * eventPtr); +static void FrameLostSlaveProc( + ClientData clientData, + Tk_Window tkWin); +static void FrameRequestProc( + ClientData clientData, + Tk_Window tkWin); +static void FrameStructureProc( + ClientData clientData, + XEvent * eventPtr); +static void FrameWorldChanged( + ClientData instanceData); +static void FrameLabelwinRemove( + tkoLabelframe * labelframe); +static void FrameMap( + ClientData clientData); + +/* + * Data + */ + +/* + * frameClass -- + * + * The structure below defines frame class behavior by means of functions that + * can be invoked from generic window code. + */ +static const Tk_ClassProcs frameClass = { + sizeof(Tk_ClassProcs), /* size */ + FrameWorldChanged, /* worldChangedProc */ + NULL, /* createProc */ + NULL /* modalProc */ +}; + +/* + * frameGeomType -- + * + * The structure below defines the official type record for the labelframe's + * geometry manager: + */ +static const Tk_GeomMgr frameGeomType = { + "labelframe", /* name */ + FrameRequestProc, /* requestProc */ + FrameLostSlaveProc /* lostSlaveProc */ +}; + +/* + * Definition of options created in object constructor. + * Order of used options in definition is important: + * -class -visual -colormap -container -use + */ + +/* Common options for all defined widgets. */ +#define FRAME_COMMONDEFINE \ + { "-background" , "background", "Background", DEF_FRAME_BG_COLOR, TKO_OPTION_NULL, \ + NULL, TKO_SET_3DBORDER, offsetof(tkoFrame, border)}, \ + { "-backgroundimage", "backgroundImage", "BackgroundImage", DEF_FRAME_BG_IMAGE, 0, \ + FrameMethod_backgroundimage ,TKO_SET_NONE, 0}, \ + { "-bg" , "-background", NULL, NULL, 0, NULL,TKO_SET_NONE,0}, \ + { "-bgimg", "-backgroundimage", NULL, NULL, 0, NULL,TKO_SET_NONE,0}, \ + { "-bd" , "-borderwidth", NULL, NULL, 0, NULL, TKO_SET_NONE,0}, \ + { "-cursor" , "cursor", "Cursor", DEF_FRAME_CURSOR, 0, \ + NULL, TKO_SET_CURSOR, offsetof(tkoFrame, cursor)}, \ + { "-height" , "height", "Height", DEF_FRAME_HEIGHT, 0, \ + NULL, TKO_SET_PIXEL, offsetof(tkoFrame, height)}, \ + { "-highlightbackground", "highlightbackground", "highlightBackground", DEF_FRAME_HIGHLIGHT_BG, 0, \ + NULL, TKO_SET_XCOLOR, offsetof(tkoFrame, highlightBgColorPtr)}, \ + { "-highlightcolor", "highlightColor", "HighlightColor", DEF_FRAME_HIGHLIGHT, 0, \ + NULL, TKO_SET_XCOLOR, offsetof(tkoFrame, highlightColorPtr)}, \ + { "-highlightthickness" , "highlightThickness", "HighlightThickness", DEF_FRAME_HIGHLIGHT_WIDTH, 0, \ + NULL, TKO_SET_PIXEL, offsetof(tkoFrame, highlightWidth)}, \ + { "-padx" , "padX", "Pad", DEF_FRAME_PADX, 0, \ + NULL, TKO_SET_PIXEL, offsetof(tkoFrame, padX)}, \ + { "-pady" , "padY", "Pad", DEF_FRAME_PADY, 0, \ + NULL, TKO_SET_PIXEL, offsetof(tkoFrame, padY)}, \ + { "-takefocus" , "takeFocus", "TakeFocus", DEF_FRAME_TAKE_FOCUS, 0, \ + NULL, TKO_SET_STRING, 0}, \ + { "-tile", "tile", "Tile", DEF_FRAME_BG_TILE, 0, \ + NULL, TKO_SET_BOOLEAN, offsetof(tkoFrame, tile)}, \ + { "-width" , "width", "Width", DEF_FRAME_WIDTH, 0, \ + NULL, TKO_SET_PIXEL, offsetof(tkoFrame, width)}, \ + { NULL,NULL,NULL,NULL,0,NULL,TKO_SET_NONE,0} + +/* + * frameOptions -- + * List of tko::frame options. + */ +static const Tko_WidgetOptionDefine frameOptions[] = { + {"-class", "class", "Class", "TkoFrame", TKO_OPTION_READONLY, + NULL, TKO_SET_CLASS, 0}, + {"-visual", "visual", "Visual", DEF_FRAME_VISUAL, TKO_OPTION_READONLY, + NULL, TKO_SET_VISUAL, 0}, + {"-colormap", "colormap", "Colormap", DEF_FRAME_COLORMAP, TKO_OPTION_READONLY, + NULL, TKO_SET_COLORMAP, 0}, + {"-container", "container", "Container", DEF_FRAME_CONTAINER, TKO_OPTION_READONLY, + NULL, TKO_SET_CONTAINER, offsetof(tkoFrame, isContainer)}, + {"-borderwidth", "borderWidth", "BorderWidth", DEF_FRAME_BORDER_WIDTH, 0, + NULL, TKO_SET_PIXEL, offsetof(tkoFrame, borderWidth)}, + {"-relief", "relief", "Relief", DEF_FRAME_RELIEF, 0, + NULL, TKO_SET_RELIEF, offsetof(tkoFrame, relief)}, + FRAME_COMMONDEFINE +}; + +/* + * toplevelOptions -- + * List of tko::toplevel options. + */ +static const Tko_WidgetOptionDefine toplevelOptions[] = { + {"-screen", "screen", "Screen", "", TKO_OPTION_READONLY, + NULL, TKO_SET_STRING, 0}, + {"-class", "class", "Class", "TkoToplevel", TKO_OPTION_READONLY, + NULL, TKO_SET_CLASS, 0}, + {"-container", "container", "Container", DEF_FRAME_CONTAINER, TKO_OPTION_READONLY, + NULL, TKO_SET_CONTAINER, offsetof(tkoFrame, isContainer)}, + {"-use", "use", "Use", DEF_TOPLEVEL_USE, TKO_OPTION_READONLY|TKO_OPTION_NULL, + NULL, TKO_SET_USE, offsetof(tkoFrame, useThis)}, + {"-visual", "visual", "Visual", DEF_FRAME_VISUAL, TKO_OPTION_READONLY, + NULL, TKO_SET_VISUAL, 0}, + {"-colormap", "colormap", "Colormap", DEF_FRAME_COLORMAP, TKO_OPTION_READONLY, + NULL, TKO_SET_COLORMAP, 0}, + {"-borderwidth", "borderWidth", "BorderWidth", DEF_FRAME_BORDER_WIDTH, 0, + NULL, TKO_SET_PIXEL, offsetof(tkoFrame, borderWidth)}, + {"-menu", "menu", "Menu", DEF_TOPLEVEL_MENU, TKO_OPTION_NULL, + FrameMethod_menu, TKO_SET_NONE, 0}, + {"-relief", "relief", "Relief", DEF_FRAME_RELIEF, 0, + NULL, TKO_SET_RELIEF, offsetof(tkoFrame, relief)}, + FRAME_COMMONDEFINE +}; + +/* + * labelframeOptions -- + * List of tko::labelframe options. + */ +static const Tko_WidgetOptionDefine labelframeOptions[] = { + {"-class", "class", "Class", "TkoLabelframe", TKO_OPTION_READONLY, + NULL, TKO_SET_CLASS, 0}, + {"-visual", "visual", "Visual", DEF_FRAME_VISUAL, TKO_OPTION_READONLY, + NULL, TKO_SET_VISUAL, 0}, + {"-colormap", "colormap", "Colormap", DEF_FRAME_COLORMAP, TKO_OPTION_READONLY, + NULL, TKO_SET_COLORMAP, 0}, + {"-borderwidth", "borderWidth", "BorderWidth", DEF_LABELFRAME_BORDER_WIDTH, 0, + NULL, TKO_SET_PIXEL, offsetof(tkoFrame, borderWidth)}, + {"-fg", "-foreground", NULL, NULL, 0, NULL, TKO_SET_NONE, 0}, + {"-font", "font", "Font", DEF_LABELFRAME_FONT, 0, + NULL, TKO_SET_FONT, offsetof(tkoLabelframe, tkfont)}, + {"-foreground", "foreground", "Foreground", DEF_LABELFRAME_FG, 0, + NULL, TKO_SET_XCOLOR, offsetof(tkoLabelframe, textColorPtr)}, + {"-labelanchor", "labelAnchor", "LabelAnchor", DEF_LABELFRAME_LABELANCHOR, 0, + FrameMethod_labelanchor, TKO_SET_NONE, 0}, + {"-labelwidget", "labelWidget", "LabelWidget", "",0, + FrameMethod_labelwidget, TKO_SET_NONE, 0}, + {"-relief", "relief", "Relief", DEF_LABELFRAME_RELIEF, 0, + NULL, TKO_SET_RELIEF, offsetof(tkoFrame, relief)}, + {"-text", "text", "Text", DEF_LABELFRAME_TEXT, 0, + NULL, TKO_SET_TCLOBJ, offsetof(tkoLabelframe, textPtr)}, + FRAME_COMMONDEFINE +}; + +/* + * Definition of object methods created in Tko_FrameInit() function. + */ + +/* + * frameMethods -- + * List of used public and private tko::frame methods. + */ +static Tcl_MethodType frameMethods[] = { + {TCL_OO_METHOD_VERSION_CURRENT, NULL, FrameConstructorFrame, NULL, NULL}, + {TCL_OO_METHOD_VERSION_CURRENT, NULL, FrameDestructor, NULL, NULL}, + {-1, NULL, NULL, NULL, NULL}, + {TCL_OO_METHOD_VERSION_CURRENT, "_tko_configure", FrameMethod_tko_configure, + NULL, NULL}, + {-1, NULL, NULL, NULL, NULL} +}; + +/* + * labelframeMethods -- + * List of used public and private tko::labelframe methods. + */ +static Tcl_MethodType labelframeMethods[] = { + {TCL_OO_METHOD_VERSION_CURRENT, NULL, FrameConstructorLabelframe, NULL, + NULL}, + {TCL_OO_METHOD_VERSION_CURRENT, NULL, FrameDestructor, NULL, NULL}, + {-1, NULL, NULL, NULL, NULL}, + {TCL_OO_METHOD_VERSION_CURRENT, "_tko_configure", FrameMethod_tko_configure, + NULL, NULL}, + {-1, NULL, NULL, NULL, NULL} +}; + +/* + * toplevelMethods -- + * List of used public and private tko::toplevel methods. + */ +static Tcl_MethodType toplevelMethods[] = { + {TCL_OO_METHOD_VERSION_CURRENT, NULL, FrameConstructorToplevel, NULL, NULL}, + {TCL_OO_METHOD_VERSION_CURRENT, NULL, FrameDestructor, NULL, NULL}, + {-1, NULL, NULL, NULL, NULL}, + {TCL_OO_METHOD_VERSION_CURRENT, "_tko_configure", FrameMethod_tko_configure, + NULL, NULL}, + {-1, NULL, NULL, NULL, NULL} +}; + +/* + * Tko_FrameInit -- + * + * Create tko frame widget class objects. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Create new oo::class's. + */ +int +Tko_FrameInit( + Tcl_Interp * interp) +{ /* Tcl interpreter. */ + Tcl_Obj *tmpPtr; + int ret; + + /* + * ::tko::toplevel + */ + tmpPtr = Tcl_NewStringObj("::tko::toplevel", -1); + Tcl_IncrRefCount(tmpPtr); + ret = Tko_WidgetClassDefine(interp, tmpPtr, + toplevelMethods, toplevelOptions); + Tcl_DecrRefCount(tmpPtr); + if (ret != TCL_OK) { + return TCL_ERROR; + } + /* + * ::tko::frame + */ + tmpPtr = Tcl_NewStringObj("::tko::frame", -1); + Tcl_IncrRefCount(tmpPtr); + ret = Tko_WidgetClassDefine(interp, tmpPtr, + frameMethods, frameOptions); + Tcl_DecrRefCount(tmpPtr); + if (ret != TCL_OK) { + return TCL_ERROR; + } + + /* + * ::tko::labelframe + */ + tmpPtr = Tcl_NewStringObj("::tko::labelframe", -1); + Tcl_IncrRefCount(tmpPtr); + ret = Tko_WidgetClassDefine(interp, tmpPtr, + labelframeMethods, labelframeOptions); + Tcl_DecrRefCount(tmpPtr); + if (ret != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; +} + +/* + * FrameConstructorFrame -- + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Call common constructor for frames. + */ +static int +FrameConstructorFrame( + ClientData dummy, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + (void)dummy; + + return FrameConstructor(TYPE_FRAME, interp, context, objc, objv); +} + +/* + * FrameConstructorLabelframe -- + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Call common constructor for labelframes. + */ +static int +FrameConstructorLabelframe( + ClientData dummy, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + (void)dummy; + return FrameConstructor(TYPE_LABELFRAME, interp, context, objc, objv); +} + +/* + * FrameConstructorToplevel -- + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Call common constructor for toplevels. + */ +static int +FrameConstructorToplevel( + ClientData dummy, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + (void)dummy; + return FrameConstructor(TYPE_TOPLEVEL, interp, context, objc, objv); +} + +/* + * FrameConstructor -- + * + * Common part of all widget contructors. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Create new widget and options. + * Set readonly options and default option values. + */ +static int +FrameConstructor( + enum FrameType type, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + Tcl_Object object; + Tko_Widget *widget; + tkoFrame *frame; + Tcl_Obj *myArglist; + int skip; + Tko_WidgetCreateMode createMode; + + /* Get current object. Should not fail? */ + if ((object = Tcl_ObjectContextObject(context)) == NULL) { + return TCL_ERROR; + } + if (type == TYPE_FRAME) { + frame = (tkoFrame *)ckalloc(sizeof(tkoFrame)); + assert(frame); + memset(frame, 0, sizeof(tkoFrame)); + createMode = TKO_CREATE_WIDGET; + } + else if (type == TYPE_LABELFRAME) { + tkoLabelframe *labelframe; + labelframe = (tkoLabelframe *)ckalloc(sizeof(tkoLabelframe)); + assert(labelframe); + memset(labelframe, 0, sizeof(tkoLabelframe)); + frame = (tkoFrame *)labelframe; + labelframe->textPtr = NULL; + labelframe->tkfont = NULL; + labelframe->textColorPtr = NULL; + labelframe->labelAnchor = LABELANCHOR_NW; + labelframe->labelWin = NULL; + labelframe->textGC = NULL; + labelframe->textLayout = NULL; + /*labelframe->labelBox */ + labelframe->labelReqWidth = 0; + labelframe->labelReqHeight = 0; + labelframe->labelTextX = 0; + labelframe->labelTextY = 0; + createMode = TKO_CREATE_WIDGET; + } + else if (type == TYPE_TOPLEVEL) { + frame = (tkoFrame *)ckalloc(sizeof(tkoFrame)); + assert(frame); + memset(frame, 0, sizeof(tkoFrame)); + createMode = TKO_CREATE_TOPLEVEL; + } + else { + Tcl_WrongNumArgs(interp, 1, objv, "internal type error"); + return TCL_ERROR; + } + widget = (Tko_Widget *)frame; + frame->type = type; + frame->menuName = NULL; + frame->colormap = None; + frame->border = NULL; + frame->borderWidth = 0; + frame->relief = TK_RELIEF_FLAT; + frame->highlightWidth = 0; + frame->highlightBgColorPtr = NULL; + frame->highlightColorPtr = NULL; + frame->width = 0; + frame->height = 0; + frame->cursor = NULL; + frame->isContainer = 0; + frame->useThis = NULL; + frame->flags = 0; + frame->padX = 0; + frame->padY = 0; + frame->mask = ExposureMask | StructureNotifyMask | FocusChangeMask; + frame->bgimg = NULL; +#ifndef TK_NO_DOUBLE_BUFFERING + frame->copyGC = NULL; +#endif + frame->tile = 0; + if (type == TYPE_TOPLEVEL) { + frame->mask |= ActivateMask; + } + skip = Tcl_ObjectContextSkippedArgs(context); + if (objc - skip > 0) { + myArglist = Tcl_NewListObj(objc - skip, &objv[skip]); + } + else { + myArglist = Tcl_NewListObj(0, NULL); + } + if (Tko_WidgetCreate(&(frame->widget), interp, object, createMode, + myArglist) != TCL_OK) { + Tcl_DecrRefCount(myArglist); + return TCL_ERROR; + } + Tcl_DecrRefCount(myArglist); + frame->tkWinCreate = widget->tkWin; + if (frame->isContainer && frame->useThis != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj + ("windows cannot have both the -use and the -container" + " option set", -1)); + Tcl_SetErrorCode(interp, "TK", "FRAME", "CONTAINMENT", NULL); + return TCL_ERROR; + } + /* + * For top-level windows, provide an initial geometry request of 200x200, + * just so the window looks nicer on the screen if it doesn't request a + * size for itself. + */ + if (type == TYPE_TOPLEVEL) { + Tk_GeometryRequest(widget->tkWin, 200, 200); + } + + /* + * Store backreference to frame widget in window structure. + */ + + Tk_SetClassProcs(widget->tkWin, &frameClass, frame); + + /* + * Mark Tk frames as suitable candidates for [wm manage]. + */ + + ((TkWindow *) widget->tkWin)->flags |= TK_WM_MANAGEABLE; + + Tk_CreateEventHandler(widget->tkWin, frame->mask, FrameEventProc, frame); + + if (type == TYPE_TOPLEVEL) { + Tcl_DoWhenIdle(FrameMap, frame); + } + + return TCL_OK; +} + +/* + * FrameDestructor -- + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Delete widget ressources. + */ +static int +FrameDestructor( + ClientData dummy, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + Tko_Widget *widget; + (void)dummy; + (void)interp; + (void)objc; + (void)objv; + + if((widget = (Tko_Widget *)Tko_WidgetClientData(context)) != NULL) { + tkoFrame *frame = (tkoFrame *)widget; + tkoLabelframe *labelframe = (tkoLabelframe *) widget; + Tcl_Preserve(widget); + + if(widget->tkWin) { + Tk_DeleteEventHandler(widget->tkWin, frame->mask, FrameEventProc, frame); + } + if(widget->display != NULL) { +#ifndef TK_NO_DOUBLE_BUFFERING + if (frame->copyGC != NULL) { + Tk_FreeGC(widget->display, frame->copyGC); + } + frame->copyGC = NULL; +#endif /* TK_NO_DOUBLE_BUFFERING */ + if(frame->cursor != NULL) { + Tk_FreeCursor(widget->display, frame->cursor); + } + frame->cursor = NULL; + } + if (frame->bgimg != NULL) { + Tk_FreeImage(frame->bgimg); + } + frame->bgimg = NULL; + frame->flags = 0; + Tcl_CancelIdleCall(FrameDisplay, frame); + Tcl_CancelIdleCall(FrameMap, frame); + + if(frame->menuName != NULL && frame->tkWinCreate) { + Tk_SetWindowMenubar(frame->widget.interp, frame->tkWinCreate, frame->menuName, NULL); + ckfree(frame->menuName); + frame->menuName = NULL; + } + if(frame->type == TYPE_LABELFRAME && labelframe->labelWin) { + Tk_ManageGeometry(labelframe->labelWin, NULL, NULL); + if(widget->tkWin && (widget->tkWin != Tk_Parent(labelframe->labelWin))) { + Tk_UnmaintainGeometry(labelframe->labelWin, widget->tkWin); + } + Tk_UnmapWindow(labelframe->labelWin); + labelframe->labelWin = NULL; + } + if (frame->useThis) { + Tcl_DecrRefCount(frame->useThis); + } + if (frame->type == TYPE_LABELFRAME) { + if (labelframe->textLayout) { + Tk_FreeTextLayout(labelframe->textLayout); + } + if (labelframe->textGC != NULL && widget->display != NULL) { + Tk_FreeGC(widget->display, labelframe->textGC); + } + } + if (frame->border) { + Tk_Free3DBorder(frame->border); + } + if (frame->colormap != None && widget->display != NULL) { + Tk_FreeColormap(widget->display, frame->colormap); + } + if (frame->highlightBgColorPtr != NULL) { + Tk_FreeColor(frame->highlightBgColorPtr); + } + if (frame->highlightColorPtr != NULL) { + Tk_FreeColor(frame->highlightColorPtr); + } + Tko_WidgetDestroy(context); + Tcl_Release(frame); + } + return TCL_OK; +} + +/* + * FrameMethod_tko_configure -- + * + * Results: + * A standard Tcl result. + * + * Side effects: + * After configure step. + */ +static int +FrameMethod_tko_configure( + ClientData dummy, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + Tko_Widget *widget; + tkoFrame *frame; + (void)dummy; + (void)interp; + (void)objc; + (void)objv; + + if((widget = (Tko_Widget *)Tko_WidgetClientData(context)) == NULL + || widget->tkWin == NULL) { + return TCL_ERROR; + } + frame = (tkoFrame *)widget; + + if(frame->border != NULL) { + Tk_SetBackgroundFromBorder(widget->tkWin, frame->border); + } else { + Tk_SetWindowBackgroundPixmap(widget->tkWin, None); + } + + if(frame->highlightWidth < 0) { + frame->highlightWidth = 0; + } + if(frame->padX < 0) { + frame->padX = 0; + } + if(frame->padY < 0) { + frame->padY = 0; + } + + FrameWorldChanged(frame); + return TCL_OK; +} + +/* + * FrameMethod_labelanchor -- + * + * Process -labelanchor option. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Set new option value. + */ +static int +FrameMethod_labelanchor( + ClientData dummy, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + int index, code; + tkoFrame *frame; + tkoLabelframe *labelframe; + Tcl_Obj *value; + static const char *const labelAnchorStrings[] = { + "e", "en", "es", "n", "ne", "nw", "s", "se", "sw", "w", "wn", "ws", + NULL + }; + (void)dummy; + + if((frame = + (tkoFrame *)Tko_WidgetClientData(context)) == NULL + || (value = + Tko_WidgetOptionGet(&frame->widget, objv[objc - 1])) == NULL) { + return TCL_ERROR; + } + labelframe = (tkoLabelframe *)frame; + code = + Tcl_GetIndexFromObj(interp, value, labelAnchorStrings, "labelanchor", 0, + &index); + if(code != TCL_OK) { + return TCL_ERROR; + } + labelframe->labelAnchor = (Tk_Anchor) index; + return TCL_OK; +} + +/* + * FrameMethod_labelwidget -- + * + * Process -labelwidget option. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Set new option value. + */ +static int +FrameMethod_labelwidget( + ClientData dummy, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + Tko_Widget *widget; + Tk_Window oldWindow = NULL; + Tk_Window newWindow = NULL; + Tk_Window ancestor, parent, sibling = NULL; + tkoLabelframe *labelframe; + Tcl_Obj *value; + (void)dummy; + + if((widget = (Tko_Widget *)Tko_WidgetClientData(context)) == NULL + || widget->tkWin == NULL + || (value = Tko_WidgetOptionGet(widget, objv[objc - 1])) == NULL) { + return TCL_ERROR; + } + labelframe = (tkoLabelframe *)widget; + + if(value == NULL || Tcl_GetCharLength(value) == 0) { + newWindow = NULL; + } else if(TkGetWindowFromObj(interp, widget->tkWin, value, &newWindow) != TCL_OK) { + return TCL_ERROR; + } + /* + * If a -labelwidget is specified, check that it is valid and set up + * geometry management for it. + */ + oldWindow = labelframe->labelWin; + if(oldWindow != newWindow) { + if(newWindow != NULL) { + /* + * Make sure that the frame is either the parent of the window + * used as label or a descendant of that parent. Also, don't + * allow a top-level window to be managed inside the frame. + */ + parent = Tk_Parent(newWindow); + for(ancestor = widget->tkWin;; ancestor = Tk_Parent(ancestor)) { + if(ancestor == parent) { + break; + } + sibling = ancestor; + if(Tk_IsTopLevel(ancestor)) { + goto badLabelWindow; + } + } + if(Tk_IsTopLevel(newWindow)) { + goto badLabelWindow; + } + if(newWindow == widget->tkWin) { + goto badLabelWindow; + } + } + if(oldWindow != NULL) { + Tk_DeleteEventHandler(oldWindow, StructureNotifyMask, + FrameStructureProc, labelframe); + Tk_ManageGeometry(oldWindow, NULL, NULL); + Tk_UnmaintainGeometry(oldWindow, widget->tkWin); + Tk_UnmapWindow(oldWindow); + } + if(newWindow != NULL) { + Tk_CreateEventHandler(newWindow, + StructureNotifyMask, FrameStructureProc, labelframe); + Tk_ManageGeometry(newWindow, &frameGeomType, labelframe); + /* + * If the frame is not parent to the label, make sure the + * label is above its sibling in the stacking order. + */ + if(sibling != NULL) { + Tk_RestackWindow(newWindow, Above, sibling); + } + } + labelframe->labelWin = newWindow; + } + return TCL_OK; + + badLabelWindow: + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("can't use %s as label in this frame", + Tk_PathName(labelframe->labelWin))); + Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "HIERARCHY", NULL); + labelframe->labelWin = NULL; + return TCL_ERROR; +} + +/* + * FrameMethod_backgroundimage -- + * + * Process -backgroundimage option. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Set new option value. + */ +static int +FrameMethod_backgroundimage( + ClientData dummy, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + Tko_Widget *widget; + tkoFrame *frame; + Tcl_Obj *value; + Tk_Image image; + (void)dummy; + + if((widget = (Tko_Widget *)Tko_WidgetClientData(context)) == NULL + || widget->tkWin == NULL + || (value = Tko_WidgetOptionGet(widget, objv[objc - 1])) == NULL) { + return TCL_ERROR; + } + frame = (tkoFrame *)widget; + /* check on widget destroyed */ + if(widget->tkWin == NULL) + return TCL_OK; + /* try to create new image */ + if(value == NULL || Tcl_GetCharLength(value) == 0) { + image = NULL; + } else { + image = Tk_GetImage(interp, widget->tkWin, + Tcl_GetString(value), FrameBgImageProc, frame); + if (image == NULL) { + return TCL_ERROR; + } + } + if (frame->bgimg) { + Tk_FreeImage(frame->bgimg); + } + frame->bgimg = image; + return TCL_OK; +} + +/* +* FrameMethod_menu -- +* +* Process -menu option. +* +* Results: +* A standard Tcl result. +* +* Side effects: +* Set new option value. +*/ +static int +FrameMethod_menu( + ClientData dummy, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + Tko_Widget *widget; + tkoFrame *frame; + Tcl_Obj *value; + char *newMenu; + int length; + (void)dummy; + + if((widget = (Tko_Widget *)Tko_WidgetClientData(context)) == NULL + || widget->tkWin == NULL + || (value = Tko_WidgetOptionGet(widget, objv[objc - 1])) == NULL) { + return TCL_ERROR; + } + frame = (tkoFrame *)widget; + + newMenu = Tcl_GetStringFromObj(value, &length); + if (length==0) { + newMenu = NULL; + } + if ((((newMenu == NULL) && (frame->menuName != NULL)) + || ((newMenu != NULL) && (frame->menuName == NULL)) + || ((newMenu != NULL) && (frame->menuName != NULL) + && strcmp(newMenu, frame->menuName) != 0)) + && frame->type == TYPE_TOPLEVEL) { + Tk_SetWindowMenubar(interp, widget->tkWin, frame->menuName, newMenu); + if (frame->menuName) { ckfree(frame->menuName); } + if (length) { + frame->menuName = (char *)ckalloc(length + 1); + assert(frame->menuName); + strncpy(frame->menuName,newMenu,length); + frame->menuName[length] = '\0'; + } + else { + frame->menuName = NULL; + } + } + return TCL_OK; +} + +/* + * FrameWorldChanged -- + * + * This function is called when the world has changed in some way and the + * widget needs to recompute all its graphics contexts and determine its + * new geometry. + * + * Results: + * None. + * + * Side effects: + * Frame will be relayed out and redisplayed. + */ +static void +FrameWorldChanged( + ClientData clientData) +{ /* Information about widget. */ + Tko_Widget *widget = (Tko_Widget *)clientData; + tkoFrame *frame = (tkoFrame *)clientData; + tkoLabelframe *labelframe = (tkoLabelframe *)clientData; + XGCValues gcValues; + GC gc; + int anyTextLabel, anyWindowLabel; + int bWidthLeft, bWidthRight, bWidthTop, bWidthBottom; + const char *labelText; + + if (widget->tkWin == NULL) { + return; + } + + anyTextLabel = (frame->type == TYPE_LABELFRAME) && + (labelframe->textPtr != NULL) && (labelframe->labelWin == NULL); + anyWindowLabel = (frame->type == TYPE_LABELFRAME) && + (labelframe->labelWin != NULL); + +#ifndef TK_NO_DOUBLE_BUFFERING + gcValues.graphics_exposures = False; + gc = Tk_GetGC(widget->tkWin, GCGraphicsExposures, &gcValues); + if (frame->copyGC != NULL) { + Tk_FreeGC(widget->display, frame->copyGC); + } + frame->copyGC = gc; +#endif /* TK_NO_DOUBLE_BUFFERING */ + + if(frame->type == TYPE_LABELFRAME) { + /* + * The textGC is needed even in the labelWin case, so it's always + * created for a labelframe. + */ + + gcValues.font = Tk_FontId(labelframe->tkfont); + gcValues.foreground = labelframe->textColorPtr->pixel; + gcValues.graphics_exposures = False; + gc = Tk_GetGC(widget->tkWin, GCForeground | GCFont | GCGraphicsExposures, + &gcValues); + if(labelframe->textGC != NULL) { + Tk_FreeGC(widget->display, labelframe->textGC); + } + labelframe->textGC = gc; + + /* + * Calculate label size. + */ + + labelframe->labelReqWidth = labelframe->labelReqHeight = 0; + + if(anyTextLabel) { + labelText = Tcl_GetString(labelframe->textPtr); + if(labelframe->textLayout) { + Tk_FreeTextLayout(labelframe->textLayout); + } + labelframe->textLayout = + Tk_ComputeTextLayout(labelframe->tkfont, + labelText, -1, 0, TK_JUSTIFY_CENTER, 0, + &labelframe->labelReqWidth, &labelframe->labelReqHeight); + labelframe->labelReqWidth += 2 * LABELSPACING; + labelframe->labelReqHeight += 2 * LABELSPACING; + } else if(anyWindowLabel) { + labelframe->labelReqWidth = Tk_ReqWidth(labelframe->labelWin); + labelframe->labelReqHeight = Tk_ReqHeight(labelframe->labelWin); + } + + /* + * Make sure label size is at least as big as the border. This + * simplifies later calculations and gives a better appearance with + * thick borders. + */ + + if((labelframe->labelAnchor >= LABELANCHOR_N) && + (labelframe->labelAnchor <= LABELANCHOR_SW)) { + if(labelframe->labelReqHeight < frame->borderWidth) { + labelframe->labelReqHeight = frame->borderWidth; + } + } else { + if(labelframe->labelReqWidth < frame->borderWidth) { + labelframe->labelReqWidth = frame->borderWidth; + } + } + } + + /* + * Calculate individual border widths. + */ + + bWidthBottom = bWidthTop = bWidthRight = bWidthLeft = + frame->borderWidth + frame->highlightWidth; + + bWidthLeft += frame->padX; + bWidthRight += frame->padX; + bWidthTop += frame->padY; + bWidthBottom += frame->padY; + + if(anyTextLabel || anyWindowLabel) { + switch (labelframe->labelAnchor) { + case LABELANCHOR_E: + case LABELANCHOR_EN: + case LABELANCHOR_ES: + bWidthRight += labelframe->labelReqWidth - frame->borderWidth; + break; + case LABELANCHOR_N: + case LABELANCHOR_NE: + case LABELANCHOR_NW: + bWidthTop += labelframe->labelReqHeight - frame->borderWidth; + break; + case LABELANCHOR_S: + case LABELANCHOR_SE: + case LABELANCHOR_SW: + bWidthBottom += labelframe->labelReqHeight - frame->borderWidth; + break; + default: + bWidthLeft += labelframe->labelReqWidth - frame->borderWidth; + break; + } + } + + Tk_SetInternalBorderEx(widget->tkWin, bWidthLeft, bWidthRight, bWidthTop, + bWidthBottom); + + FrameComputeGeometry(frame); + + /* + * A labelframe should request size for its label. + */ + + if(frame->type == TYPE_LABELFRAME) { + int minwidth = labelframe->labelReqWidth; + int minheight = labelframe->labelReqHeight; + int padding = frame->highlightWidth; + + if(frame->borderWidth > 0) { + padding += frame->borderWidth + LABELMARGIN; + } + padding *= 2; + if((labelframe->labelAnchor >= LABELANCHOR_N) && + (labelframe->labelAnchor <= LABELANCHOR_SW)) { + minwidth += padding; + minheight += frame->borderWidth + frame->highlightWidth; + } else { + minheight += padding; + minwidth += frame->borderWidth + frame->highlightWidth; + } + Tk_SetMinimumRequestSize(widget->tkWin, minwidth, minheight); + } + + if((frame->width > 0) || (frame->height > 0)) { + Tk_GeometryRequest(widget->tkWin, frame->width, frame->height); + } + + if(Tk_IsMapped(widget->tkWin)) { + if(!(frame->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(FrameDisplay, frame); + } + frame->flags |= REDRAW_PENDING; + } +} + +/* + * FrameComputeGeometry -- + * + * This function is called to compute various geometrical information for + * a frame, such as where various things get displayed. It's called when + * the window is reconfigured. + * + * Results: + * None. + * + * Side effects: + * Display-related numbers get changed in *frame. + */ + +static void +FrameComputeGeometry( + tkoFrame * frame) +{ + int otherWidth, otherHeight, otherWidthT, otherHeightT, padding; + int maxWidth, maxHeight; + Tko_Widget *widget = (Tko_Widget *)frame; + tkoLabelframe *labelframe = (tkoLabelframe *) frame; + + /* + * We have nothing to do here unless there is a label. + */ + if (widget->tkWin == NULL || frame->type != TYPE_LABELFRAME) { + return; + } + + if(labelframe->textPtr == NULL && labelframe->labelWin == NULL) { + return; + } + + /* + * Calculate the available size for the label + */ + + labelframe->labelBox.width = labelframe->labelReqWidth; + labelframe->labelBox.height = labelframe->labelReqHeight; + + padding = frame->highlightWidth; + if(frame->borderWidth > 0) { + padding += frame->borderWidth + LABELMARGIN; + } + padding *= 2; + + maxHeight = Tk_Height(widget->tkWin); + maxWidth = Tk_Width(widget->tkWin); + + if((labelframe->labelAnchor >= LABELANCHOR_N) && + (labelframe->labelAnchor <= LABELANCHOR_SW)) { + maxWidth -= padding; + if(maxWidth < 1) { + maxWidth = 1; + } + } else { + maxHeight -= padding; + if(maxHeight < 1) { + maxHeight = 1; + } + } + if(labelframe->labelBox.width > maxWidth) { + labelframe->labelBox.width = maxWidth; + } + if(labelframe->labelBox.height > maxHeight) { + labelframe->labelBox.height = maxHeight; + } + + /* + * Calculate label and text position. The text's position is based on the + * requested size (= the text's real size) to get proper alignment if the + * text does not fit. + */ + + otherWidth = Tk_Width(widget->tkWin) - labelframe->labelBox.width; + otherHeight = Tk_Height(widget->tkWin) - labelframe->labelBox.height; + otherWidthT = Tk_Width(widget->tkWin) - labelframe->labelReqWidth; + otherHeightT = Tk_Height(widget->tkWin) - labelframe->labelReqHeight; + padding = frame->highlightWidth; + + switch (labelframe->labelAnchor) { + case LABELANCHOR_E: + case LABELANCHOR_EN: + case LABELANCHOR_ES: + labelframe->labelTextX = otherWidthT - padding; + labelframe->labelBox.x = otherWidth - padding; + break; + case LABELANCHOR_N: + case LABELANCHOR_NE: + case LABELANCHOR_NW: + labelframe->labelTextY = padding; + labelframe->labelBox.y = padding; + break; + case LABELANCHOR_S: + case LABELANCHOR_SE: + case LABELANCHOR_SW: + labelframe->labelTextY = otherHeightT - padding; + labelframe->labelBox.y = otherHeight - padding; + break; + default: + labelframe->labelTextX = padding; + labelframe->labelBox.x = padding; + break; + } + + if(frame->borderWidth > 0) { + padding += frame->borderWidth + LABELMARGIN; + } + + switch (labelframe->labelAnchor) { + case LABELANCHOR_NW: + case LABELANCHOR_SW: + labelframe->labelTextX = padding; + labelframe->labelBox.x = padding; + break; + case LABELANCHOR_N: + case LABELANCHOR_S: + labelframe->labelTextX = otherWidthT / 2; + labelframe->labelBox.x = otherWidth / 2; + break; + case LABELANCHOR_NE: + case LABELANCHOR_SE: + labelframe->labelTextX = otherWidthT - padding; + labelframe->labelBox.x = otherWidth - padding; + break; + case LABELANCHOR_EN: + case LABELANCHOR_WN: + labelframe->labelTextY = padding; + labelframe->labelBox.y = padding; + break; + case LABELANCHOR_E: + case LABELANCHOR_W: + labelframe->labelTextY = otherHeightT / 2; + labelframe->labelBox.y = otherHeight / 2; + break; + default: + labelframe->labelTextY = otherHeightT - padding; + labelframe->labelBox.y = otherHeight - padding; + break; + } +} + +/* + * FrameDisplay -- + * + * This function is invoked to display a frame widget. + * + * Results: + * None. + * + * Side effects: + * Commands are output to X to display the frame in its current mode. + */ +static void +FrameDisplay( + ClientData clientData /* Information about widget. */) +{ + Tko_Widget *widget = (Tko_Widget *)clientData; + tkoFrame *frame = (tkoFrame *)clientData; + int bdX1, bdY1, bdX2, bdY2, hlWidth; + Pixmap pixmap; + TkRegion clipRegion = NULL; + + if (widget->tkWin == NULL) { + return; + } + + frame->flags &= ~REDRAW_PENDING; + if(!Tk_IsMapped(widget->tkWin)) { + return; + } + + /* + * Highlight shall always be drawn if it exists, so do that first. + */ + + hlWidth = frame->highlightWidth; + + if(hlWidth != 0) { + GC fgGC, bgGC; + + bgGC = Tk_GCForColor(frame->highlightBgColorPtr, + Tk_WindowId(widget->tkWin)); + if(frame->flags & GOT_FOCUS) { + fgGC = Tk_GCForColor(frame->highlightColorPtr, + Tk_WindowId(widget->tkWin)); + Tk_DrawHighlightBorder(widget->tkWin, fgGC, bgGC, hlWidth, + Tk_WindowId(widget->tkWin)); + } else { + Tk_DrawHighlightBorder(widget->tkWin, bgGC, bgGC, hlWidth, + Tk_WindowId(widget->tkWin)); + } + } + + /* + * If -background is set to "", no interior is drawn. + */ + + if(frame->border == NULL) { + return; + } + +#ifndef TK_NO_DOUBLE_BUFFERING + /* + * In order to avoid screen flashes, this function redraws the frame into + * off-screen memory, then copies it back on-screen in a single operation. + * This means there's no point in time where the on-screen image has been + * cleared. + */ + + pixmap = Tk_GetPixmap(widget->display, Tk_WindowId(widget->tkWin), + Tk_Width(widget->tkWin), Tk_Height(widget->tkWin), Tk_Depth(widget->tkWin)); +#else + pixmap = Tk_WindowId(widget->tkWin); +#endif /* TK_NO_DOUBLE_BUFFERING */ + + if(frame->type != TYPE_LABELFRAME) { + /* + * Pass to platform specific draw function. In general, it just draws + * a simple rectangle, but it may "theme" the background. + */ + + noLabel: + TkpDrawFrameEx(widget->tkWin, pixmap, frame->border, + hlWidth, frame->borderWidth, frame->relief); + if (frame->bgimg) { + FrameDrawBackground(widget->tkWin, pixmap, hlWidth, + frame->borderWidth, frame->bgimg, frame->tile); + } + } else { + tkoLabelframe *labelframe = (tkoLabelframe *) frame; + + if((labelframe->textPtr == NULL) && (labelframe->labelWin == NULL)) { + goto noLabel; + } + + /* + * Clear the pixmap. + */ + + Tk_Fill3DRectangle(widget->tkWin, pixmap, frame->border, 0, 0, + Tk_Width(widget->tkWin), Tk_Height(widget->tkWin), 0, + TK_RELIEF_FLAT); + + /* + * Calculate how the label affects the border's position. + */ + + bdX1 = bdY1 = hlWidth; + bdX2 = Tk_Width(widget->tkWin) - hlWidth; + bdY2 = Tk_Height(widget->tkWin) - hlWidth; + + switch (labelframe->labelAnchor) { + case LABELANCHOR_E: + case LABELANCHOR_EN: + case LABELANCHOR_ES: + bdX2 -= (labelframe->labelBox.width - frame->borderWidth) / 2; + break; + case LABELANCHOR_N: + case LABELANCHOR_NE: + case LABELANCHOR_NW: + /* + * Since the glyphs of the text tend to be in the lower part we + * favor a lower border position by rounding up. + */ + + bdY1 += (labelframe->labelBox.height - frame->borderWidth + 1) / 2; + break; + case LABELANCHOR_S: + case LABELANCHOR_SE: + case LABELANCHOR_SW: + bdY2 -= (labelframe->labelBox.height - frame->borderWidth) / 2; + break; + default: + bdX1 += (labelframe->labelBox.width - frame->borderWidth) / 2; + break; + } + + /* + * Draw border + */ + + Tk_Draw3DRectangle(widget->tkWin, pixmap, frame->border, bdX1, bdY1, + bdX2 - bdX1, bdY2 - bdY1, frame->borderWidth, frame->relief); + + if(labelframe->labelWin == NULL) { + /* + * Clear behind the label + */ + + Tk_Fill3DRectangle(widget->tkWin, pixmap, + frame->border, labelframe->labelBox.x, + labelframe->labelBox.y, labelframe->labelBox.width, + labelframe->labelBox.height, 0, TK_RELIEF_FLAT); + + /* + * Draw label. If there is not room for the entire label, use + * clipping to get a nice appearance. + */ + + if((labelframe->labelBox.width < labelframe->labelReqWidth) + || (labelframe->labelBox.height < labelframe->labelReqHeight)) { + clipRegion = TkCreateRegion(); + TkUnionRectWithRegion(&labelframe->labelBox, clipRegion, + clipRegion); + TkSetRegion(widget->display, labelframe->textGC, clipRegion); + } + + Tk_DrawTextLayout(widget->display, pixmap, + labelframe->textGC, labelframe->textLayout, + labelframe->labelTextX + LABELSPACING, + labelframe->labelTextY + LABELSPACING, 0, -1); + + if(clipRegion != NULL) { + XSetClipMask(widget->display, labelframe->textGC, None); + TkDestroyRegion(clipRegion); + } + } else { + /* + * Reposition and map the window (but in different ways depending + * on whether the frame is the window's parent). + */ + + if(widget->tkWin == Tk_Parent(labelframe->labelWin)) { + if((labelframe->labelBox.x != Tk_X(labelframe->labelWin)) + || (labelframe->labelBox.y != Tk_Y(labelframe->labelWin)) + || (labelframe->labelBox.width != + Tk_Width(labelframe->labelWin)) + || (labelframe->labelBox.height != + Tk_Height(labelframe->labelWin))) { + Tk_MoveResizeWindow(labelframe->labelWin, + labelframe->labelBox.x, + labelframe->labelBox.y, + labelframe->labelBox.width, + labelframe->labelBox.height); + } + Tk_MapWindow(labelframe->labelWin); + } else { + Tk_MaintainGeometry(labelframe->labelWin, widget->tkWin, + labelframe->labelBox.x, labelframe->labelBox.y, + labelframe->labelBox.width, labelframe->labelBox.height); + } + } + } +#ifndef TK_NO_DOUBLE_BUFFERING + /* + * Everything's been redisplayed; now copy the pixmap onto the screen + * and free up the pixmap. + */ + + XCopyArea(widget->display, pixmap, Tk_WindowId(widget->tkWin), + frame->copyGC, hlWidth, hlWidth, + (unsigned)(Tk_Width(widget->tkWin) - 2 * hlWidth), + (unsigned)(Tk_Height(widget->tkWin) - 2 * hlWidth), + hlWidth, hlWidth); + Tk_FreePixmap(widget->display, pixmap); +#endif /* TK_NO_DOUBLE_BUFFERING */ +} + +/* + * FrameEventProc -- + * + * This function is invoked by the Tk dispatcher on structure changes to + * a frame. For frames with 3D borders, this function is also invoked for + * exposures. + * + * Results: + * None. + * + * Side effects: + * When the window gets deleted, internal structures get cleaned up. + * When it gets exposed, it is redisplayed. + */ +static void +FrameEventProc( + ClientData clientData, /* Information about window. */ + register XEvent * eventPtr) +{ /* Information about event. */ + Tko_Widget *widget = (Tko_Widget *)clientData; + tkoFrame *frame = (tkoFrame *)clientData; + if(eventPtr->type == DestroyNotify || widget->tkWin == NULL + || widget->tkWin == NULL) + return; + + if((eventPtr->type == Expose) && (eventPtr->xexpose.count == 0)) { + goto redraw; + } else if(eventPtr->type == ConfigureNotify) { + FrameComputeGeometry(frame); + goto redraw; + } else if(eventPtr->type == FocusIn) { + if(eventPtr->xfocus.detail != NotifyInferior) { + frame->flags |= GOT_FOCUS; + if(frame->highlightWidth > 0) { + goto redraw; + } + } + } else if(eventPtr->type == FocusOut) { + if(eventPtr->xfocus.detail != NotifyInferior) { + frame->flags &= ~GOT_FOCUS; + if(frame->highlightWidth > 0) { + goto redraw; + } + } + } else if(eventPtr->type == ActivateNotify) { + Tk_SetMainMenubar(frame->widget.interp, widget->tkWin, frame->menuName); + } + return; + + redraw: + if(!(frame->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(FrameDisplay, frame); + frame->flags |= REDRAW_PENDING; + } +} + +/* + * FrameMap -- + * + * This function is invoked as a when-idle handler to map a newly-created + * top-level frame. + * + * Results: + * None. + * + * Side effects: + * The frame given by the clientData argument is mapped. + */ +static void +FrameMap( + ClientData clientData) +{ /* Pointer to frame structure. */ + Tko_Widget *widget = (Tko_Widget *)clientData; + tkoFrame *frame = (tkoFrame *)clientData; + + if (widget->tkWin == NULL) { + return; + } + + /* + * Wait for all other background events to be processed before mapping + * window. This ensures that the window's correct geometry will have been + * determined before it is first mapped, so that the window manager + * doesn't get a false idea of its desired geometry. + */ + + Tcl_Preserve(frame); + while(1) { + if(Tcl_DoOneEvent(TCL_IDLE_EVENTS) == 0) { + break; + } + + /* + * After each event, make sure that the window still exists and quit + * if the window has been destroyed. + */ + if(widget->tkWin == NULL) { + Tcl_Release(frame); + return; + } + } + Tk_MapWindow(widget->tkWin); + Tcl_Release(frame); +} + + +/* + * FrameStructureProc -- + * + * This function is invoked whenever StructureNotify events occur for a + * window that's managed as label for the frame. This procudure's only + * purpose is to clean up when windows are deleted. + * + * Results: + * None. + * + * Side effects: + * The window is disassociated from the frame when it is deleted. + */ +static void +FrameStructureProc( + ClientData clientData, /* Pointer to record describing frame. */ + XEvent * eventPtr) +{ /* Describes what just happened. */ + tkoLabelframe *labelframe = (tkoLabelframe *)clientData; + + /* + * This should only happen in a labelframe but it doesn't hurt to be + * careful. + */ + if((eventPtr->type == DestroyNotify) + && (labelframe->frame.type == TYPE_LABELFRAME)) { + FrameLabelwinRemove(labelframe); + } +} + +/* + * FrameLabelwinRemove -- + * + * Results: + * None. + * + * Side effects: + */ +static void +FrameLabelwinRemove( + tkoLabelframe * labelframe) +{ + tkoFrame *frame = (tkoFrame *) labelframe; + Tcl_Obj *tmpPtr; + + labelframe->labelWin = NULL; + tmpPtr = Tcl_NewStringObj("-labelwidget", -1); + Tcl_IncrRefCount(tmpPtr); + Tko_WidgetOptionSet(&frame->widget, tmpPtr, Tcl_NewStringObj("", 0)); + Tcl_DecrRefCount(tmpPtr); + FrameWorldChanged(labelframe); +} + +/* + * FrameRequestProc -- + * + * This function is invoked whenever a window that's associated with a + * frame changes its requested dimensions. + * + * Results: + * None. + * + * Side effects: + * The size and location on the screen of the window may change depending + * on the options specified for the frame. + */ +static void +FrameRequestProc( + ClientData clientData, /* Pointer to record for frame. */ + Tk_Window tkWin) +{ /* Window that changed its desired size. */ + tkoFrame *frame = (tkoFrame *)clientData; + (void)tkWin; + + FrameWorldChanged(frame); +} + +/* + * FrameLostSlaveProc -- + * + * This function is invoked by Tk whenever some other geometry claims + * control over a slave that used to be managed by us. + * + * Results: + * None. + * + * Side effects: + * Forgets all frame-related information about the slave. + */ +static void +FrameLostSlaveProc( + ClientData clientData, /* Frame structure for slave window that was + * stolen away. */ + Tk_Window tkWin /* Tk's handle for the slave window. */) +{ + tkoLabelframe *labelframe = (tkoLabelframe *)clientData; + + /* + * This should only happen in a labelframe but it doesn't hurt to be + * careful. + */ + + if(labelframe->frame.type == TYPE_LABELFRAME) { + Tk_DeleteEventHandler(labelframe->labelWin, StructureNotifyMask, + FrameStructureProc, labelframe); + if(tkWin != Tk_Parent(labelframe->labelWin)) { + Tk_UnmaintainGeometry(labelframe->labelWin, tkWin); + } + Tk_UnmapWindow(labelframe->labelWin); + FrameLabelwinRemove(labelframe); + } +} + +/* + *---------------------------------------------------------------------- + * + * FrameBgImageProc -- + * + * This function is invoked by the image code whenever the manager for an + * image does something that affects the size or contents of an image + * displayed on a frame's background. + * + * Results: + * None. + * + * Side effects: + * Arranges for the button to get redisplayed. + * + *---------------------------------------------------------------------- + */ + +static void +FrameBgImageProc( + ClientData clientData, /* Pointer to widget record. */ + int x, int y, /* Upper left pixel (within image) that must + * be redisplayed. */ + int width, int height, /* Dimensions of area to redisplay (might be + * <= 0). */ + int imgWidth, int imgHeight)/* New dimensions of image. */ +{ + Tko_Widget *widget = (Tko_Widget *)clientData; + tkoFrame *frame = (tkoFrame *)clientData; + (void)x; + (void)y; + (void)width; + (void)height; + (void)imgWidth; + (void)imgHeight; + + if (widget->tkWin == NULL) return; + + /* + * Changing the background image never alters the dimensions of the frame. + */ + + if (Tk_IsMapped(widget->tkWin) && + !(frame->flags & REDRAW_PENDING)) { + Tcl_DoWhenIdle(FrameDisplay, frame); + frame->flags |= REDRAW_PENDING; + } +} + +/* + *---------------------------------------------------------------------- + * + * FrameDrawBackground -- + * + * This function draws the background image of a rectangular frame area. + * + * Results: + * None. + * + * Side effects: + * Draws inside the tkwin area. + * + *---------------------------------------------------------------------- + */ + +static void +FrameDrawBackground( + Tk_Window tkwin, + Pixmap pixmap, + int highlightWidth, + int borderWidth, + Tk_Image bgimg, + int bgtile) +{ + int width, height; /* Area to paint on. */ + int imageWidth, imageHeight; /* Dimensions of image. */ + const int bw = highlightWidth + borderWidth; + + Tk_SizeOfImage(bgimg, &imageWidth, &imageHeight); + width = Tk_Width(tkwin) - 2*bw; + height = Tk_Height(tkwin) - 2*bw; + + if (bgtile) { + /* + * Draw the image tiled in the widget (inside the border). + */ + + int x, y; + + for (x = bw; x - bw < width; x += imageWidth) { + int w = imageWidth; + if (x - bw + imageWidth > width) { + w = (width + bw) - x; + } + for (y = bw; y < height + bw; y += imageHeight) { + int h = imageHeight; + if (y - bw + imageHeight > height) { + h = (height + bw) - y; + } + Tk_RedrawImage(bgimg, 0, 0, w, h, pixmap, x, y); + } + } + } else { + /* + * Draw the image centred in the widget (inside the border). + */ + + int x, y, xOff, yOff, w, h; + + if (width > imageWidth) { + x = 0; + xOff = (Tk_Width(tkwin) - imageWidth) / 2; + w = imageWidth; + } else { + x = (imageWidth - width) / 2; + xOff = bw; + w = width; + } + if (height > imageHeight) { + y = 0; + yOff = (Tk_Height(tkwin) - imageHeight) / 2; + h = imageHeight; + } else { + y = (imageHeight - height) / 2; + yOff = bw; + h = height; + } + Tk_RedrawImage(bgimg, x, y, w, h, pixmap, xOff, yOff); + } +} + +/* vim: set ts=4 sw=4 sts=4 ff=unix et : */ ADDED generic/tko/tkoWidget.c Index: generic/tko/tkoWidget.c ================================================================== --- /dev/null +++ generic/tko/tkoWidget.c @@ -0,0 +1,3276 @@ +/* + * tkoWidget.c -- + * + * This file contains the tko widget class. + * + * Copyright (c) 2019 Rene Zaumseil + * + */ + +#include "tkoWidget.h" +#include "tclOOInt.h" /*TODO needed for Widget_GetClassName() below */ + +/* + * Widget_GetClassName -- + * Return class name of object. + * Should be OO core function. + * + * Results: + * Name of class or NULL on error. + * + * Side effects: + * Use internal OO structures!!! + */ +Tcl_Obj * +Widget_GetClassName( + Tcl_Interp * interp, + Tcl_Object object) +{ + Tcl_Object classPtr; + classPtr = (Tcl_Object)(((Object *)object)->selfCls->thisPtr); + if (classPtr == NULL) return NULL; + + return Tcl_GetObjectName(interp, classPtr); +} + +/* + * Widget option. + */ +typedef struct WidgetOption { + Tcl_Obj *option; /* Name of option */ + Tcl_Obj *dbname; /* Database name or name of synonym option */ + Tcl_Obj *dbclass; /* Class name or NULL for synonym options */ + Tcl_Obj *defvalue; /* Default value from initialization */ + Tcl_Obj *flags; /* Default value from initialization */ + Tcl_Obj *value; /* Contain last known value of option */ + int flagbits; /* see flags in struct Tko_WidgetOptionDefine */ +} WidgetOption; + +/* + * Clientdata of option methods. + */ +typedef struct WidgetClientdata { + Tcl_MethodType method; + Tcl_Obj *option; + int offset; + int type; + int flags; +} WidgetClientdata; + +typedef struct TkoThreadData { + /* UID of class sctring */ + Tk_Uid Uid_class; + Tk_Uid Uid_empty; + /* Static string objects. */ + Tcl_Obj *Obj_empty; /* "" */ + Tcl_Obj *Obj_tko__option; /* "::tko::_option" */ + Tcl_Obj *Obj_tko__eventoption; /* "::tko::_eventoption" */ + Tcl_Obj *Obj_next; /* "next" */ + Tcl_Obj *Obj_uplevel; /* "::uplevel" */ + Tcl_Obj *Obj_oo_define; /* "::oo::define" */ + Tcl_Obj *Obj_oo_objdefine; /* "::oo::objdefine" */ + Tcl_Obj *Obj_method; /* "method" */ + Tcl_Obj *Obj__tko_configure; /* "_tko_configure" */ + Tcl_Obj *Obj__tko; /* "_tko" */ + Tcl_Obj *Obj_cget; /* "cget" */ + Tcl_Obj *Obj_configure; /* "configure" */ + Tcl_Obj *Obj_tko; /* "::tko" */ + Tcl_Obj *Obj_tko_widget; /* "::tko::widget" */ + Tcl_Obj *Obj_lsort; /* "::lsort" */ + Tcl_Obj *Obj_point; /* "." */ + Tcl_Obj *Obj_point2; /* ".." */ + Tcl_Obj *Obj__screen; /* "-screen" */ + Tcl_Obj *Obj_flags_r; /* "r" */ + Tcl_Obj *Obj_flags_rh; /* "rh" */ + Tcl_Obj *Obj_flags_h; /* "h" */ + Tcl_Obj *Obj_rename; /* "rename" */ + Tcl_Obj *Obj_tko__self; /* "::tko::_self" */ +} TkoThreadData; +static Tcl_ThreadDataKey tkoKey; + +/* + * Methods + */ +static int WidgetMethod_cget( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); +static int WidgetMethod_configure( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); +static int WidgetMethod_tko_configure( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); +static int WidgetMethod_tko( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); + +/* + * Functions + */ +static char *WidgetOptionTrace( + ClientData clientData, + Tcl_Interp * interp, + const char *name1, + const char *name2, + int flags); +static void WidgetOptionDelEntry( + Tcl_HashEntry * entry); +static void WidgetEventProc( + ClientData clientData, + XEvent * eventPtr); +static void WidgetEventChanged( + Tko_Widget *widget); +static int WidgetOptionAdd( + Tcl_Interp * interp, + Tko_Widget * widget, + Tcl_Obj * option, + Tcl_Obj * dbname, + Tcl_Obj * dbclass, + Tcl_Obj * defvalue, + Tcl_Obj * flags, + Tcl_Obj * value, + int initmode); +static int WidgetOptionGet( + Tcl_Interp * interp, + Tko_Widget * widget, + Tcl_Obj * option); +static int WidgetOptionSet( + Tcl_Interp * interp, + Tko_Widget * widget, + Tcl_Obj * option, + Tcl_Obj * value); +static void WidgetMetaDestroy( + Tko_Widget * widget); +static void WidgetMetaDelete( + ClientData clientData); +static int WidgetMethod_( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); +static int WidgetFlagsObj( + Tcl_Obj *flagsPtr, + int *flags); +static int WidgetFlagsHideGet( + Tcl_Obj *flags); +static Tcl_Obj *WidgetFlagsHideSet( + Tcl_Obj *flags); +static Tcl_Obj *WidgetFlagsHideUnset( + Tcl_Obj *flags); +static void WidgetClientdataDelete( + ClientData clientdata); +static int WidgetClientdataClone( + Tcl_Interp *interp, + ClientData clientdata, + ClientData *newPtr); +static int WidgetDestructor( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); +static int WidgetWrapConstructor( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); +static int WidgetClassConstructor( + ClientData clientData, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]); +static void WidgetDeleteTkwin( + Tko_Widget *widget); + +/* List of all internally defined public and private methods. */ +#define TKO_1 TCL_OO_METHOD_VERSION_CURRENT +static Tcl_MethodType tkoWidgetMethods[] = { + { TKO_1, NULL, WidgetClassConstructor, NULL, NULL }, + { TKO_1, NULL, WidgetWrapConstructor, NULL, NULL }, + { TKO_1, NULL, WidgetDestructor, NULL, NULL }, + { TKO_1, "cget", WidgetMethod_cget, NULL, NULL }, + { TKO_1, "configure", WidgetMethod_configure, NULL, NULL }, + { TKO_1, "_tko_configure", WidgetMethod_tko_configure, NULL, NULL }, + { TKO_1, "_tko", WidgetMethod_tko, NULL, NULL }, +}; + +/* + * tkoWidgetMeta -- + * Identifier for attached tko widget data. + */ +Tcl_ObjectMetadataType tkoWidgetMeta = { + TCL_OO_METADATA_VERSION_CURRENT, + "tkoWidgetMeta", + WidgetMetaDelete, + NULL +}; + +/* +* Tko_TkoObjCmd -- +* Implementation of the "::tko" command. +* Initialization of new widgets. +* Configuration of widget class options. +* +* Results: +* A standard Tcl result. +* +* Side effects: +* Create available oo::class tko widgets. +* Add, delete return, hide and show options. +*/ +int +Tko_TkoObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const myOptions[] = { + "initclass", "initfrom", "initwrap", + "eventoption", + "optiondef", "optiondel","optionget", + "optionhide","optionshow",NULL + }; + enum options { + MY_INITCLASS, MY_INITFROM, MY_INITWRAP, + MY_EVENTOPTION, + MY_OPTIONDEF, MY_OPTIONDEL, MY_OPTIONGET, + MY_OPTIONHIDE, MY_OPTIONSHOW + }; + int index; + Tcl_Obj *dictPtr; + Tcl_Obj *namePtr; + Tcl_Obj *listPtr; + int ret; + int i; + Tcl_DictSearch search; + Tcl_Obj *key, *value; + int argObjc; + Tcl_Obj **argObjv; + int done; + Tcl_Obj *myCmd[6]; + const char *ch, *ch1; + int length; + Tcl_Obj *tmpPtr; + Tcl_Class clazz; + Tcl_Object object; + TkoThreadData *tkoPtr = (TkoThreadData *)Tcl_GetThreadData(&tkoKey, sizeof(TkoThreadData)); + (void)dummy; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObjStruct(interp, objv[1], myOptions, + sizeof(char *), "option", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum options) index) { + case MY_INITCLASS: /* Add cget/configure functionalite to current class */ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 2, objv, ""); + return TCL_ERROR; + } + ret = Tcl_Eval(interp, "set ::tko::_option([self]) {} ; variable tko ; self"); + if (ret != TCL_OK) { + return TCL_ERROR; + } + /* Get class object */ + tmpPtr = Tcl_GetObjResult(interp); + if ((object = Tcl_GetObjectFromObj(interp, tmpPtr)) == NULL + || (clazz = Tcl_GetObjectAsClass(object)) == NULL) { + return TCL_ERROR; + } + /* + * Add methods + */ + Tcl_ClassSetConstructor(interp, clazz, + Tcl_NewMethod(interp, clazz, NULL, 1, &tkoWidgetMethods[0], NULL)); + Tcl_ClassSetDestructor(interp, clazz, + Tcl_NewMethod(interp, clazz, NULL, 1, &tkoWidgetMethods[2], NULL)); + Tcl_NewMethod(interp, clazz, tkoPtr->Obj_cget, 1, &tkoWidgetMethods[3], NULL); + Tcl_NewMethod(interp, clazz, tkoPtr->Obj_configure, 1, &tkoWidgetMethods[4], NULL); + Tcl_NewMethod(interp, clazz, tkoPtr->Obj__tko_configure, 0, &tkoWidgetMethods[5], NULL); + Tcl_NewMethod(interp, clazz, tkoPtr->Obj__tko, 0, &tkoWidgetMethods[6], NULL); + + return TCL_OK; + case MY_INITFROM: /* Initialize new tko class */ + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "tkoclass"); + return TCL_ERROR; + } + /* Use fqn superclass and get all options from it */ + ch = Tcl_GetStringFromObj(objv[2], &length); + if (length < 2 || ch[0] != ':') { + tmpPtr = Tcl_ObjPrintf( + "set ::tko::_option([self]) {} ; unexport destroy; variable tko; {*}$::tko::_unknown\n" + "superclass ::%s ; set ::tko::_option([self]) [::tko optionget ::%s]", + ch,ch); + } + else{ + tmpPtr = Tcl_ObjPrintf( + "set ::tko::_option([self]) {} ; unexport destroy; variable tko; {*}$::tko::_unknown\n" + "superclass %s ; set ::tko::_option([self]) [::tko optionget %s]", + ch,ch); + } + Tcl_IncrRefCount(tmpPtr); + ret = Tcl_Eval(interp, Tcl_GetString(tmpPtr)); + Tcl_DecrRefCount(tmpPtr); + if (ret != TCL_OK) { + return TCL_ERROR; + } + return TCL_OK; + case MY_INITWRAP: /* Wrap widget in new class */ + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "widget readonlyoptionlist methodlist"); + return TCL_ERROR; + } + /* Create fqn widgetname */ + ch = Tcl_GetStringFromObj(objv[2], &length); + if (length < 2 || ch[0] != ':') { + namePtr = Tcl_ObjPrintf("::%s", Tcl_GetString(objv[2])); + } + else { + namePtr = objv[2]; + } + Tcl_IncrRefCount(namePtr); + ch = Tcl_GetString(namePtr); + ch1 = Tcl_GetString(objv[3]); + tmpPtr = Tcl_ObjPrintf("set ::tko::_option([self]) {}\n" + "unexport destroy ; variable tko\n" + "::tko::_initwrap [self] %s {%s} {%s}\n" + "self method unknown {pathName args} {\n" + " set a {}; foreach {o v} $args {if {$o in {%s}} {lappend a $o $v}}\n" + " rename [%s $pathName {*}$a] ::tko::$pathName\n" + " tailcall [[self] create ::$pathName {*}$args] configure .\n" + "}\n" + "self", + ch,ch1,Tcl_GetString(objv[4]),ch1,ch); + Tcl_IncrRefCount(tmpPtr); + ret = Tcl_Eval(interp, Tcl_GetString(tmpPtr)); + Tcl_DecrRefCount(namePtr); + Tcl_DecrRefCount(tmpPtr); + if (ret != TCL_OK) { + return TCL_ERROR; + } + /* Get class object */ + tmpPtr = Tcl_GetObjResult(interp); + if ((object = Tcl_GetObjectFromObj(interp, tmpPtr)) == NULL + || (clazz = Tcl_GetObjectAsClass(object)) == NULL) { + return TCL_ERROR; + } + /* + * Add methods + */ + Tcl_ClassSetConstructor(interp, clazz, + Tcl_NewMethod(interp, clazz, NULL, 1, &tkoWidgetMethods[1], NULL)); + Tcl_ClassSetDestructor(interp, clazz, + Tcl_NewMethod(interp, clazz, NULL, 1, &tkoWidgetMethods[2], NULL)); + Tcl_NewMethod(interp, clazz, tkoPtr->Obj_cget, 1, &tkoWidgetMethods[3], NULL); + Tcl_NewMethod(interp, clazz, tkoPtr->Obj_configure, 1, &tkoWidgetMethods[4], NULL); + Tcl_NewMethod(interp, clazz, tkoPtr->Obj__tko_configure, 0, &tkoWidgetMethods[5], NULL); + Tcl_NewMethod(interp, clazz, tkoPtr->Obj__tko, 0, &tkoWidgetMethods[6], NULL); + + return TCL_OK; + case MY_EVENTOPTION: /* Call proc ::tko::_eventoption */ + return Tcl_EvalObjEx(interp, tkoPtr->Obj_tko__eventoption, TCL_EVAL_GLOBAL); + case MY_OPTIONDEF: /* Add or replace option definitions and return new state */ + if (objc != 3 && objc < 5) { + Tcl_WrongNumArgs(interp, 2, objv, "::classname ?-option definition? .. ?body?"); + return TCL_ERROR; + } + /* Create fqn classname */ + ch = Tcl_GetStringFromObj(objv[2], &length); + if (length < 2 || ch[0] != ':') { + namePtr = Tcl_ObjPrintf("::%s", Tcl_GetString(objv[2])); + } + else { + namePtr = objv[2]; + } + Tcl_IncrRefCount(namePtr); + /* get current value or create new one */ + dictPtr = Tcl_ObjGetVar2(interp, tkoPtr->Obj_tko__option, namePtr, TCL_GLOBAL_ONLY); + if (dictPtr == NULL) { + dictPtr = Tcl_NewObj(); + } + else { + dictPtr = Tcl_DuplicateObj(dictPtr); + } + Tcl_IncrRefCount(dictPtr); + /* if no options then return current state */ + if (objc == 3) { + Tcl_SetObjResult(interp, dictPtr); + Tcl_DecrRefCount(dictPtr); + Tcl_DecrRefCount(namePtr); + return TCL_OK; + } + /* Add or replace options */ + for (i = 3; i < objc-1; i = i + 2) { + /* check definition list */ + if (Tcl_ListObjGetElements(interp, objv[i + 1], &argObjc, &argObjv) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("no definition list: %s {%s}", + Tcl_GetString(objv[i]), Tcl_GetString(objv[i + 1]))); + Tcl_DecrRefCount(dictPtr); + Tcl_DecrRefCount(namePtr); + return TCL_ERROR; + } + /* Check definition list */ + switch (argObjc) { + case 2: /* synonym flags */ + ret = WidgetOptionAdd(interp, NULL, objv[i], argObjv[0], NULL, NULL, argObjv[1], NULL, 0); + if (ret == TCL_OK) { + ret = Tcl_DictObjPut(interp, dictPtr, objv[i], objv[i + 1]); + } + break; + case 4: /* dbname dbclass default flags */ + ret = WidgetOptionAdd(interp, NULL, objv[i], argObjv[0], argObjv[1], argObjv[2], argObjv[3], NULL, 0); + if (ret == TCL_OK) { + ret = Tcl_DictObjPut(interp, dictPtr, objv[i], objv[i + 1]); + } + break; + default: + Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrong definition: %s {%s}", + Tcl_GetString(objv[i]), Tcl_GetString(objv[i + 1]))); + ret = TCL_ERROR; + } + if (ret != TCL_OK) { + Tcl_DecrRefCount(dictPtr); + Tcl_DecrRefCount(namePtr); + return TCL_ERROR; + } + + } + /* Add body to last definition. */ + if (objc % 2 == 0) { + myCmd[0] = tkoPtr->Obj_oo_define; + myCmd[1] = namePtr; + myCmd[2] = tkoPtr->Obj_method; + myCmd[3] = objv[objc - 3]; + myCmd[4] = tkoPtr->Obj_empty; + myCmd[5] = objv[objc - 1]; + ret = Tcl_EvalObjv(interp, 6, myCmd, TCL_EVAL_GLOBAL); + if (ret != TCL_OK) { + Tcl_DecrRefCount(dictPtr); + Tcl_DecrRefCount(namePtr); + return TCL_ERROR; + } + } tmpPtr = Tcl_ObjSetVar2(interp, tkoPtr->Obj_tko__option, namePtr, dictPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(dictPtr); + Tcl_DecrRefCount(namePtr); + if (tmpPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, tmpPtr); + return TCL_OK; + case MY_OPTIONDEL: /* Delete option definitions and return new state */ + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "::classname ?-option? .."); + return TCL_ERROR; + } + /* Create fqn classname */ + ch = Tcl_GetStringFromObj(objv[2], &length); + if (length < 2 || ch[0] != ':') { + namePtr = Tcl_ObjPrintf("::%s", Tcl_GetString(objv[2])); + } + else { + namePtr = objv[2]; + } + Tcl_IncrRefCount(namePtr); + /* if no options then remove all options */ + if (objc == 3) { + tmpPtr = Tcl_ObjSetVar2(interp, tkoPtr->Obj_tko__option, namePtr,tkoPtr->Obj_empty,TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(namePtr); + if (tmpPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, tmpPtr); + return TCL_OK; + } + /* remove given options from dictionary */ + dictPtr = Tcl_ObjGetVar2(interp, tkoPtr->Obj_tko__option, namePtr, TCL_GLOBAL_ONLY); + if (dictPtr == NULL) { + Tcl_DecrRefCount(namePtr); + return TCL_ERROR; + } + dictPtr = Tcl_DuplicateObj(dictPtr); + Tcl_IncrRefCount(dictPtr); + /* remove with error check */ + for (i = 3; i < objc; i++) { + if (Tcl_DictObjRemove(interp, dictPtr, objv[i]) != TCL_OK) { + Tcl_DecrRefCount(dictPtr); + Tcl_DecrRefCount(namePtr); + return TCL_ERROR; + } + } + tmpPtr = Tcl_ObjSetVar2(interp, tkoPtr->Obj_tko__option, namePtr,dictPtr,TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(dictPtr); + Tcl_DecrRefCount(namePtr); + if (tmpPtr == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, tmpPtr); + return TCL_OK; + case MY_OPTIONGET: /* Return all or selected option definitions */ + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "::classname ?-option? .."); + return TCL_ERROR; + } + /* Create fqn classname */ + ch = Tcl_GetStringFromObj(objv[2], &length); + if (length < 2 || ch[0] != ':') { + namePtr = Tcl_ObjPrintf("::%s", Tcl_GetString(objv[2])); + } + else { + namePtr = objv[2]; + } + Tcl_IncrRefCount(namePtr); + /* return all definitions */ + dictPtr = Tcl_ObjGetVar2(interp, tkoPtr->Obj_tko__option, namePtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(namePtr); + if (dictPtr == NULL) { + Tcl_DecrRefCount(namePtr); + return TCL_ERROR; + } + if (objc == 3) { + Tcl_SetObjResult(interp, dictPtr); + return TCL_OK; + } + /* return only selected definitions */ + listPtr = Tcl_NewListObj(0, NULL); + Tcl_IncrRefCount(listPtr); + /* get with error checks */ + for (i = 3; i < objc; i++) { + if (Tcl_DictObjGet(interp, dictPtr, objv[i], &tmpPtr) != TCL_OK + || tmpPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unknown option: %s", + Tcl_GetString(objv[i]))); + Tcl_DecrRefCount(listPtr); + return TCL_ERROR; + } + Tcl_ListObjAppendElement(interp, listPtr, objv[i]); + Tcl_ListObjAppendElement(interp, listPtr, tmpPtr); + } + Tcl_SetObjResult(interp, listPtr); + Tcl_DecrRefCount(listPtr); + return TCL_OK; + case MY_OPTIONHIDE: /* Hide given options or return all hide'able options */ + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "::classname ?-option? .."); + return TCL_ERROR; + } + /* Create fqn classname */ + ch = Tcl_GetStringFromObj(objv[2], &length); + if (length < 2 || ch[0] != ':') { + namePtr = Tcl_ObjPrintf("::%s", Tcl_GetString(objv[2])); + } + else { + namePtr = objv[2]; + } + Tcl_IncrRefCount(namePtr); + dictPtr = Tcl_ObjGetVar2(interp, tkoPtr->Obj_tko__option, namePtr, TCL_GLOBAL_ONLY); + if (dictPtr == NULL) { + Tcl_DecrRefCount(namePtr); + return TCL_ERROR; + } + /* return list of hide'able options */ + if (objc == 3) { + /* return list of visible options */ + if (Tcl_DictObjFirst(interp, dictPtr, &search, + &key, &value, &done) != TCL_OK) { + Tcl_DecrRefCount(namePtr); + return TCL_ERROR; + } + listPtr = Tcl_NewListObj(0, NULL); + for (; !done; Tcl_DictObjNext(&search, &key, &value, &done)) { + Tcl_ListObjGetElements(interp, value, &argObjc, &argObjv); + switch (argObjc) { + case 1: + case 3: + Tcl_ListObjAppendElement(interp, listPtr, key); + break; + case 2: + if (WidgetFlagsHideGet(argObjv[1]) == 0) { + Tcl_ListObjAppendElement(interp, listPtr, key); + } + break; + case 4: + if (WidgetFlagsHideGet(argObjv[3]) == 0) { + Tcl_ListObjAppendElement(interp, listPtr, key); + } + break; + } + /* ignore internal error on wrong definition lists */ + } + Tcl_DictObjDone(&search); + Tcl_SetObjResult(interp, listPtr); + Tcl_DecrRefCount(namePtr); + return TCL_OK; + } + /* hide given options */ + dictPtr = Tcl_DuplicateObj(dictPtr); + Tcl_IncrRefCount(dictPtr); + for (i = 3; i < objc; i++) { + if (Tcl_DictObjGet(interp, dictPtr, objv[i], &listPtr) != TCL_OK + || listPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unknown option: %s", + Tcl_GetString(objv[i]))); + Tcl_DecrRefCount(dictPtr); + Tcl_DecrRefCount(namePtr); + return TCL_ERROR; + } + Tcl_ListObjGetElements(interp, listPtr, &argObjc, &argObjv); + listPtr = NULL; + switch (argObjc) { + case 1: + listPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, listPtr, argObjv[0]); + Tcl_ListObjAppendElement(interp, listPtr, tkoPtr->Obj_flags_h); + break; + case 2: + listPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, listPtr, argObjv[0]); + Tcl_ListObjAppendElement(interp, listPtr, WidgetFlagsHideSet(argObjv[1])); + break; + case 3: + listPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, listPtr, argObjv[0]); + Tcl_ListObjAppendElement(interp, listPtr, argObjv[1]); + Tcl_ListObjAppendElement(interp, listPtr, argObjv[2]); + Tcl_ListObjAppendElement(interp, listPtr, tkoPtr->Obj_flags_h); + break; + case 4: + listPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, listPtr, argObjv[0]); + Tcl_ListObjAppendElement(interp, listPtr, argObjv[1]); + Tcl_ListObjAppendElement(interp, listPtr, argObjv[2]); + Tcl_ListObjAppendElement(interp, listPtr, WidgetFlagsHideSet(argObjv[3])); + break; + default: /* ignore internal error */ + continue; + } + if (Tcl_DictObjPut(interp, dictPtr, objv[i], listPtr) != TCL_OK) { + Tcl_DecrRefCount(dictPtr); + Tcl_DecrRefCount(namePtr); + return TCL_ERROR; + } + } + tmpPtr = Tcl_ObjSetVar2(interp, tkoPtr->Obj_tko__option, namePtr, dictPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(dictPtr); + Tcl_DecrRefCount(namePtr); + if (tmpPtr == NULL) { + return TCL_ERROR; + } + return TCL_OK; + case MY_OPTIONSHOW: /* Show given options or return all hidden options */ + if (objc < 3) { + Tcl_WrongNumArgs(interp, 2, objv, "::classname ?-option? .."); + return TCL_ERROR; + } + /* Create fqn classname */ + ch = Tcl_GetStringFromObj(objv[2], &length); + if (length < 2 || ch[0] != ':') { + namePtr = Tcl_ObjPrintf("::%s", Tcl_GetString(objv[2])); + } + else { + namePtr = objv[2]; + } + Tcl_IncrRefCount(namePtr); + dictPtr = Tcl_ObjGetVar2(interp, tkoPtr->Obj_tko__option, namePtr, TCL_GLOBAL_ONLY); + if (dictPtr == NULL) { + Tcl_DecrRefCount(namePtr); + return TCL_ERROR; + } + /* return list of show'able options */ + if (objc == 3) { + /* return list of visible options */ + if (Tcl_DictObjFirst(interp, dictPtr, &search, + &key, &value, &done) != TCL_OK) { + Tcl_DecrRefCount(namePtr); + return TCL_ERROR; + } + listPtr = Tcl_NewListObj(0, NULL); + for (; !done; Tcl_DictObjNext(&search, &key, &value, &done)) { + Tcl_ListObjGetElements(interp, value, &argObjc, &argObjv); + if (argObjc == 2) { + if (WidgetFlagsHideGet(argObjv[1]) == 1) { + Tcl_ListObjAppendElement(interp, listPtr, key); + } + } else if (argObjc == 4) { + if (WidgetFlagsHideGet(argObjv[3]) == 1) { + Tcl_ListObjAppendElement(interp, listPtr, key); + } + } + } + Tcl_DictObjDone(&search); + Tcl_SetObjResult(interp, listPtr); + Tcl_DecrRefCount(namePtr); + return TCL_OK; + } + /* show given options */ + dictPtr = Tcl_DuplicateObj(dictPtr); + Tcl_IncrRefCount(dictPtr); + for (i = 3; i < objc; i++) { + if (Tcl_DictObjGet(interp, dictPtr, objv[i], &listPtr) != TCL_OK + || listPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unknown option: %s", + Tcl_GetString(objv[i]))); + Tcl_DecrRefCount(dictPtr); + Tcl_DecrRefCount(namePtr); + return TCL_ERROR; + } + Tcl_ListObjGetElements(interp, listPtr, &argObjc, &argObjv); + switch (argObjc) { + case 1: /* already visible */ + continue; + case 2: + listPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, listPtr, argObjv[0]); + Tcl_ListObjAppendElement(interp, listPtr, WidgetFlagsHideUnset(argObjv[1])); + break; + case 3: /* already visible */ + continue; + case 4: + listPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, listPtr, argObjv[0]); + Tcl_ListObjAppendElement(interp, listPtr, argObjv[1]); + Tcl_ListObjAppendElement(interp, listPtr, argObjv[2]); + Tcl_ListObjAppendElement(interp, listPtr, WidgetFlagsHideUnset(argObjv[3])); + continue; + default: /* ignore internal error */ + continue; + } + if (Tcl_DictObjPut(interp, dictPtr, objv[i], listPtr) != TCL_OK) { + Tcl_DecrRefCount(dictPtr); + Tcl_DecrRefCount(namePtr); + return TCL_ERROR; + } + } + tmpPtr = Tcl_ObjSetVar2(interp, tkoPtr->Obj_tko__option, namePtr, dictPtr, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(dictPtr); + Tcl_DecrRefCount(namePtr); + if (tmpPtr == NULL) { + return TCL_ERROR; + } + return TCL_OK; + } + return TCL_ERROR; +} + +/* +* WidgetMethod_tko -- +* Implementation of the "my _tko" method. +* Configuration of widget object options. +* +* Results: +* A standard Tcl result. +* +* Side effects: +*/ +static int WidgetMethod_tko( + ClientData dummy, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + static const char *const myOptions[] = { + "optionadd", "optiondel", + "optionhide", "optionshow",NULL + }; + enum options { + MY_OPTIONADD, MY_OPTIONDEL, + MY_OPTIONHIDE, MY_OPTIONSHOW + }; + int index; + Tcl_Obj *listPtr; + int i; + Tko_Widget *widget; + int skip; + Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + WidgetOption *optionPtr; + Tcl_Obj *myCmd[6]; + Tcl_Object object; + int argObjc; + Tcl_Obj **argObjv; + TkoThreadData *tkoPtr = (TkoThreadData *)Tcl_GetThreadData(&tkoKey, sizeof(TkoThreadData)); + (void)dummy; + + widget = (Tko_Widget *) Tko_WidgetClientData(context); + if (widget == NULL || widget->myCmd == NULL) { + return TCL_ERROR; + } + skip = Tcl_ObjectContextSkippedArgs(context); + + if (objc-skip <= 0) { + Tcl_WrongNumArgs(interp, objc, objv, "option ?arg ...?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObjStruct(interp, objv[skip], myOptions, + sizeof(char *), "option", 0, &index) != TCL_OK) { + return TCL_ERROR; + } + + switch ((enum options) index) { + case MY_OPTIONADD: + if (objc - skip != 3 && objc - skip != 4) { + Tcl_WrongNumArgs(interp, skip + 1, objv, + "-option definitionlist ?body?"); + } + /* Check definition list */ + if (Tcl_ListObjGetElements(interp, objv[skip + 2], &argObjc, &argObjv) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("no definition list: %s {%s}", + Tcl_GetString(objv[skip+1]), Tcl_GetString(objv[skip+2]))); + return TCL_ERROR; + } + /* Add body if given. */ + if (objc - skip == 4) { + object = Tcl_ObjectContextObject(context); + if (object == NULL) return TCL_ERROR; + myCmd[0] = tkoPtr->Obj_oo_objdefine; + myCmd[1] = Tcl_GetObjectName(interp, object); + myCmd[2] = tkoPtr->Obj_method; + myCmd[3] = objv[skip + 1]; + myCmd[4] = tkoPtr->Obj_empty; + myCmd[5] = objv[skip + 3]; + if (Tcl_EvalObjv(interp, 6, myCmd, TCL_EVAL_GLOBAL) != TCL_OK) { + return TCL_ERROR; + } + } + switch (argObjc) { + case 2: /* synonym flags */ + return (WidgetOptionAdd(interp, widget, objv[skip+1], argObjv[0], NULL, NULL, argObjv[1], NULL, 0)); + case 4: /* dbname dbclass default flags */ + return (WidgetOptionAdd(interp, widget, objv[skip+1], argObjv[0], argObjv[1], argObjv[2], argObjv[3], NULL, 0)); + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrong definition list: %s {%s}", + Tcl_GetString(objv[skip+1]), Tcl_GetString(objv[skip+2]))); + return TCL_ERROR; + case MY_OPTIONDEL: /* delete object options */ + for (i= skip+1; ioptionsTable, + Tk_GetUid(Tcl_GetString(objv[i]))); + if (entryPtr == NULL) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("unknown option \"%s\"", Tcl_GetString(objv[i]))); + return TCL_ERROR; + } + /* delete with no additional check on synonym option */ + Tcl_UnsetVar2(interp, Tcl_GetString(widget->optionsArray), + Tcl_GetString(objv[i]), TCL_GLOBAL_ONLY); + WidgetOptionDelEntry(entryPtr); + } + return TCL_OK; + case MY_OPTIONHIDE: + /* Without args return all not hidden options */ + if ((objc - skip) == 1) { + listPtr = Tcl_NewListObj(0,NULL); + entryPtr = Tcl_FirstHashEntry(widget->optionsTable, &search); + while (entryPtr != NULL) { + optionPtr = (WidgetOption *)Tcl_GetHashValue(entryPtr); + entryPtr = Tcl_NextHashEntry(&search); + if ((optionPtr->flagbits&TKO_OPTION_HIDE)==0) { + Tcl_ListObjAppendElement(interp, listPtr, optionPtr->option); + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; + } + /* Hide given options */ + skip++; + while (skip < objc) { + entryPtr = Tcl_FindHashEntry(widget->optionsTable, + Tk_GetUid(Tcl_GetString(objv[skip]))); + if (entryPtr == NULL) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("unknown option \"%s\"", Tcl_GetString(objv[skip]))); + return TCL_ERROR; + } + optionPtr = (WidgetOption *)Tcl_GetHashValue(entryPtr); + optionPtr->flagbits |= TKO_OPTION_HIDE; + skip++; + } + return TCL_OK; + case MY_OPTIONSHOW: + /* Without args return all hidden options */ + if ((objc - skip) == 1) { + listPtr = Tcl_NewObj(); + entryPtr = Tcl_FirstHashEntry(widget->optionsTable, &search); + while (entryPtr != NULL) { + optionPtr = (WidgetOption *)Tcl_GetHashValue(entryPtr); + entryPtr = Tcl_NextHashEntry(&search); + if (optionPtr->flagbits & TKO_OPTION_HIDE) { + Tcl_ListObjAppendElement(interp, listPtr, optionPtr->option); + } + } + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; + } + /* Show given options */ + skip++; + while (skip < objc) { + entryPtr = Tcl_FindHashEntry(widget->optionsTable, + Tk_GetUid(Tcl_GetString(objv[skip]))); + if (entryPtr == NULL) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("unknown option \"%s\"", Tcl_GetString(objv[skip]))); + return TCL_ERROR; + } + optionPtr = (WidgetOption *)Tcl_GetHashValue(entryPtr); + optionPtr->flagbits &= ~TKO_OPTION_HIDE; + skip++; + } + return TCL_OK; + } + return TCL_OK; +} + + +/* +* Tko_Init -- +* Initialize tko widgets. +* +* Results: +* A standard Tcl result. +* +* Side effects: +* Create available oo::class tko widgets. +*/ +int +Tko_Init( + Tcl_Interp * interp /* Tcl interpreter. */) +{ + /* Create common tko variables. */ + /* tko::_eventoption according library/ttk.tcl proc ttk::ThemeChanged */ + static const char initScript[] = + "namespace eval ::tko {}\n" + "array set ::tko::_option {}\n" + "set ::tko::_unknown [list self method unknown {pathName args} {\n" + " tailcall [[self] create ::$pathName {*}$args] configure .\n" + "}]\n" + "proc ::tko::_eventoption {} {\n" + " set l .\n" + " while {[llength $l]} {\n" + " set l1 [list]\n" + " foreach w $l {\n" + " event generate $w <>\n" + " foreach c [winfo children $w] {\n" + " lappend l1 $c\n" + " }\n" + " }\n" + " set l $l1\n" + " }\n" + "}\n" + "proc ::tko::_initwrap {class widget ro ml} {\n" + " catch {destroy .__tko__}\n" + " set myConf [[$widget .__tko__] configure]\n" + " destroy .__tko__\n" + " foreach myCmd $ml {\n" + " if {$myCmd in {cget configure}} continue\n" + " uplevel 1 [list method $myCmd args \"\\$tko(..) $myCmd {*}\\$args\"]\n" + " }\n" + " foreach myList $myConf {\n" + " lassign $myList o n c d\n" + " switch [llength $myList] {\n" + " 2 {::tko optiondef $class $o [list $n {}]}\n" + " 5 {if {$o in $ro} {set f r} else {set f {}}\n" + " ::tko optiondef $class $o [list $n $c $d $f ] \"\\$tko(..) configure $o \\$tko($o) ; set tko($o) \\[\\$tko(..) cget $o\\]\"\n" + " }\n" + " }\n" + " }\n" + "}"; + TkoThreadData *tkoPtr = (TkoThreadData *)Tcl_GetThreadData(&tkoKey, sizeof(TkoThreadData)); + + /* Needed oo extension */ + if (Tcl_OOInitStubs(interp) == NULL) { + return TCL_ERROR; + } + /* + * Create tko namespace and data + */ + if (Tcl_Eval(interp, initScript) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Constants + */ + tkoPtr->Uid_class = Tk_GetUid("-class"); + tkoPtr->Uid_empty = Tk_GetUid(""); + Tcl_IncrRefCount((tkoPtr->Obj_empty = Tcl_NewStringObj("", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_tko__option = + Tcl_NewStringObj("::tko::_option", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_tko__eventoption = + Tcl_NewStringObj("::tko::_eventoption", -1))); + /* Internally visible */ + Tcl_IncrRefCount((tkoPtr->Obj_next = Tcl_NewStringObj("next", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_uplevel = Tcl_NewStringObj("::uplevel", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_oo_define = + Tcl_NewStringObj("::oo::define", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_oo_objdefine = + Tcl_NewStringObj("::oo::objdefine", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_method = Tcl_NewStringObj("method", -1))); + Tcl_IncrRefCount((tkoPtr->Obj__tko_configure = + Tcl_NewStringObj("_tko_configure", -1))); + Tcl_IncrRefCount((tkoPtr->Obj__tko = + Tcl_NewStringObj("_tko", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_cget = + Tcl_NewStringObj("cget", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_configure = + Tcl_NewStringObj("configure", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_tko = Tcl_NewStringObj("::tko", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_tko_widget = + Tcl_NewStringObj("::tko::widget", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_lsort = Tcl_NewStringObj("::lsort", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_point = Tcl_NewStringObj(".", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_point2 = Tcl_NewStringObj("..", -1))); + Tcl_IncrRefCount((tkoPtr->Obj__screen = Tcl_NewStringObj("-screen", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_flags_r = Tcl_NewStringObj("r", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_flags_rh = Tcl_NewStringObj("rh", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_flags_h = Tcl_NewStringObj("h", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_rename = Tcl_NewStringObj("rename", -1))); + Tcl_IncrRefCount((tkoPtr->Obj_tko__self = Tcl_NewStringObj("::tko::_self", -1))); + /* commands */ + Tcl_CreateObjCommand(interp, "::tko", Tko_TkoObjCmd, NULL, NULL); + + if (Tko_FrameInit(interp) != TCL_OK) { + return TCL_ERROR; + } +/* TODO */ +#ifdef USE_RBC + if (Tko_GraphInit(interp) != TCL_OK) { + return TCL_ERROR; + } + if (Tko_VectorInit(interp) != TCL_OK) { + return TCL_ERROR; + } +#endif + return TCL_OK; +} + +/* + * Tko_WidgetClassDefine -- + * Create a new tko widget class. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Create new class with methods and option defines. + */ +int +Tko_WidgetClassDefine( + Tcl_Interp * interp, + Tcl_Obj * classname, + const Tcl_MethodType * methods, + const Tko_WidgetOptionDefine * options) +{ + Tcl_Class clazz; + Tcl_Object object; + Tcl_Obj *listPtr; + Tcl_Obj *optionPtr; + Tcl_Obj *tmpObj; + Tcl_Obj *dictPtr; + WidgetClientdata *clientdata; + int i; + TkoThreadData *tkoPtr = (TkoThreadData *)Tcl_GetThreadData(&tkoKey, sizeof(TkoThreadData)); + + if (classname == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("missing class name")); + return TCL_ERROR; + } + /* + * Create widget class. + */ + tmpObj = Tcl_ObjPrintf("::oo::class create %s {unexport destroy; variable tko; {*}$::tko::_unknown}", Tcl_GetString(classname)); + Tcl_IncrRefCount(tmpObj); + if (Tcl_GlobalEval(interp, Tcl_GetString(tmpObj)) != TCL_OK) { + Tcl_DecrRefCount(tmpObj); + return TCL_ERROR; + } + Tcl_DecrRefCount(tmpObj); + + /* Get class object */ + if ((object = Tcl_GetObjectFromObj(interp, classname)) == NULL + || (clazz = Tcl_GetObjectAsClass(object)) == NULL) { + return TCL_ERROR; + } + + /* + * Add methods + */ + if(methods) { + /* constructor */ + if(methods[0].name == NULL && methods[0].callProc) { + Tcl_ClassSetConstructor(interp, clazz, + Tcl_NewMethod(interp, clazz, NULL, 1, &methods[0], NULL)); + } + /* destructor */ + if(methods[1].name == NULL && methods[1].callProc) { + Tcl_ClassSetDestructor(interp, clazz, + Tcl_NewMethod(interp, clazz, NULL, 1, &methods[1], NULL)); + } + /* our own methods */ + Tcl_NewMethod(interp, clazz, tkoPtr->Obj_cget, 1, &tkoWidgetMethods[3], NULL); + Tcl_NewMethod(interp, clazz, tkoPtr->Obj_configure, 1, &tkoWidgetMethods[4], NULL); + Tcl_NewMethod(interp, clazz, tkoPtr->Obj__tko_configure, 0, &tkoWidgetMethods[5], NULL); + Tcl_NewMethod(interp, clazz, tkoPtr->Obj__tko, 0, &tkoWidgetMethods[6], NULL); + /* public */ + for(i = 2; methods[i].name != NULL; i++) { + tmpObj = Tcl_NewStringObj(methods[i].name, -1); + Tcl_IncrRefCount(tmpObj); + Tcl_NewMethod(interp, clazz, tmpObj, 1, &methods[i], NULL); + Tcl_DecrRefCount(tmpObj); + } + i++; + /* private */ + for(; methods[i].name != NULL; i++) { + tmpObj = Tcl_NewStringObj(methods[i].name, -1); + Tcl_IncrRefCount(tmpObj); + Tcl_NewMethod(interp, clazz, tmpObj, 0, &methods[i], NULL); + Tcl_DecrRefCount(tmpObj); + } + } + /* + *Add options + */ + if(options) { + /* get dict variable */ + dictPtr = Tcl_ObjGetVar2(interp, tkoPtr->Obj_tko__option, classname, + TCL_GLOBAL_ONLY); + if (dictPtr == NULL) { + dictPtr = Tcl_NewDictObj(); + } + else { + dictPtr = Tcl_DuplicateObj(dictPtr); + } + Tcl_IncrRefCount(dictPtr); + /* Loop over all option definitions */ + for(i = 0;; i++) { + /* test on end of options */ + if (options[i].option == NULL) { + break; + } + /* test option name starting with "-" */ + if (options[i].option[0] != '-') { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrong option name: %s", + options[i].option)); + Tcl_DecrRefCount(dictPtr); + return TCL_ERROR; + } + /* we need at least an synonym name here */ + if(options[i].dbname == NULL) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("wrong option definition: %d", i)); + Tcl_DecrRefCount(dictPtr); + return TCL_ERROR; + } + /* no dbclass means synonym option definition */ + if (options[i].dbclass == NULL || options[i].dbclass[0] == '\0') { + /* test synonym option starting with "-" */ + if (options[i].dbname[0] != '-') { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrong synonym name: %s", + options[i].dbname)); + Tcl_DecrRefCount(dictPtr); + return TCL_ERROR; + } + } + /* we build all options with {dbname dbclass defvalue flag} */ + optionPtr = Tcl_NewStringObj(options[i].option, -1); + Tcl_IncrRefCount(optionPtr); + listPtr = Tcl_NewListObj(0, NULL); + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(options[i].dbname, -1)); + /* only if not synonym option */ + if (options[i].dbclass != NULL) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(options[i].dbclass, -1)); + if (options[i].defvalue == NULL) { + Tcl_ListObjAppendElement(interp, listPtr, tkoPtr->Obj_empty); + } + else { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(options[i].defvalue, -1)); + } + } + /* always add flags */ + if (options[i].flags & TKO_OPTION_READONLY) { + if (options[i].flags & TKO_OPTION_HIDE) { + Tcl_ListObjAppendElement(interp, listPtr, tkoPtr->Obj_flags_rh); + } + Tcl_ListObjAppendElement(interp, listPtr, tkoPtr->Obj_flags_r); + } + else if (options[i].flags & TKO_OPTION_HIDE) { + Tcl_ListObjAppendElement(interp, listPtr, tkoPtr->Obj_flags_h); + } + else { + Tcl_ListObjAppendElement(interp, listPtr, tkoPtr->Obj_empty); + } + if (Tcl_DictObjPut(interp, dictPtr, optionPtr, listPtr) != TCL_OK) { + Tcl_DecrRefCount(optionPtr); + Tcl_DecrRefCount(dictPtr); + return TCL_ERROR; + } + /* + * Now we create the necessary -option method if provided. + * If given we create the -option method with the given method. + * Or we use the internal implementation of a given type. + * If none of the above are provided it is up to the caller + * to create the necessary -option method. + */ + if (options[i].method != NULL || options[i].type >= 0) { + clientdata = (WidgetClientdata *)ckalloc(sizeof(WidgetClientdata)); + assert(clientdata); + clientdata->method.version = TCL_OO_METHOD_VERSION_CURRENT; + clientdata->method.name = options[i].option; + if (options[i].method != NULL) { + clientdata->method.callProc = options[i].method; + } + else { + clientdata->method.callProc = WidgetMethod_; + } + clientdata->method.deleteProc = WidgetClientdataDelete; + clientdata->method.cloneProc = WidgetClientdataClone; + clientdata->option = optionPtr;/* we do not decrement here */ + clientdata->offset = options[i].offset; + clientdata->type = options[i].type; + clientdata->flags = options[i].flags; + Tcl_NewMethod(interp, clazz, optionPtr, 0, &clientdata->method, + (ClientData) clientdata); + } + else { + Tcl_DecrRefCount(optionPtr); + } + } + if (Tcl_ObjSetVar2(interp, tkoPtr->Obj_tko__option, classname, dictPtr, + TCL_GLOBAL_ONLY) == 0) { + Tcl_DecrRefCount(dictPtr); + return TCL_ERROR; + } + Tcl_DecrRefCount(dictPtr); + } + return TCL_OK; +} + +/* +* WidgetDestructor -- +* +* Results: +* A standard Tcl result. +* +* Side effects: +* Delete widget ressources. +*/ +static int +WidgetDestructor( + ClientData dummy, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + Tko_Widget *widget; + (void)dummy; + (void)interp; + (void)objc; + (void)objv; + + if ((widget = (Tko_Widget *)Tko_WidgetClientData(context)) != NULL) { + Tcl_Preserve(widget); + Tko_WidgetDestroy(context); + Tcl_Release(widget); + } + return TCL_OK; +} + +/* +* WidgetClassConstructor -- +* Create a new tko class object with common methods. +* +* Results: +* A standard Tcl result. +* +* Side effects: +* Create new object with methods and option defines. + */ +static int +WidgetClassConstructor( + ClientData dummy, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + Tcl_Object object; + Tko_Widget *widget; + Tcl_Obj *myArglist; + int skip; + (void)dummy; + + /* Get current object. Should not fail? */ + if ((object = Tcl_ObjectContextObject(context)) == NULL) { + return TCL_ERROR; + } + + /* Create and initialize internal widget structure */ + widget = (Tko_Widget *)ckalloc(sizeof(Tko_Widget)); + assert(widget); + memset(widget, 0, sizeof(Tko_Widget)); + + skip = Tcl_ObjectContextSkippedArgs(context); + if (objc - skip > 0) { + myArglist = Tcl_NewListObj(objc - skip, &objv[skip]); + } + else { + myArglist = Tcl_NewListObj(0,NULL); + } + Tcl_IncrRefCount(myArglist); + if (Tko_WidgetCreate(widget, interp, object, TKO_CREATE_CLASS, + myArglist) != TCL_OK) { + Tcl_DecrRefCount(myArglist); + return TCL_ERROR; + } + Tcl_DecrRefCount(myArglist); + return TCL_OK; +} + +/* +* WidgetWrapConstructor -- +* Create a new tko widget object with wrapping of the given widget command. +* +* Results: +* A standard Tcl result. +* +* Side effects: +* Create new object with methods and option defines. +*/ +static int +WidgetWrapConstructor( + ClientData dummy, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + Tcl_Object object; + Tko_Widget *widget; + Tcl_Obj *myArglist; + int skip; + const char *ch; + int length; + Tk_Window tkWin; + Tk_Window tkWinTmp; /* tmp. created window to get Tk_Window from embedded window */ + Tcl_Obj *tmpPtr; /* tmp. string for evaluating code */ + (void)dummy; + + /* Get current object. Should not fail? */ + if ((object = Tcl_ObjectContextObject(context)) == NULL) { + return TCL_ERROR; + } + /* Check widget name on "::.*" */ + ch = NULL; + if ((tmpPtr = Tcl_GetObjectName(interp, object)) == NULL + || (ch = TclGetStringFromObj(tmpPtr, &length)) == NULL + || length < 4 || ch[0] != ':' || ch[1] != ':' || ch[2] != '.') { + if (ch == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("no pathName")); + } + else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrong pathName: %s", ch)); + } + return TCL_ERROR; + } + + /* + * Get real widget Tk_Window. + */ + tmpPtr = Tcl_NewStringObj(&ch[2], length - 2); + Tcl_AppendToObj(tmpPtr, ".1", 2); + Tcl_IncrRefCount(tmpPtr); + tkWinTmp = Tk_CreateWindowFromPath(interp, Tk_MainWindow(interp), Tcl_GetString(tmpPtr), NULL); + Tcl_DecrRefCount(tmpPtr); + if (tkWinTmp == NULL) { + return TCL_ERROR; + } + tkWin = Tk_NameToWindow(interp, &ch[2], tkWinTmp); + Tk_DestroyWindow(tkWinTmp); + if (tkWin == NULL) { + return TCL_ERROR; + } + + /* Create and initialize internal widget structure */ + widget = (Tko_Widget *)ckalloc(sizeof(Tko_Widget)); + assert(widget); + memset(widget, 0, sizeof(Tko_Widget)); + widget->tkWin = tkWin; + + skip = Tcl_ObjectContextSkippedArgs(context); + if (objc - skip > 0) { + myArglist = Tcl_NewListObj(objc - skip, &objv[skip]); + } + else { + myArglist = Tcl_NewListObj(0, NULL); + } + Tcl_IncrRefCount(myArglist); + if (Tko_WidgetCreate(widget, interp, object, TKO_CREATE_WRAP, + myArglist) != TCL_OK) { + Tcl_DecrRefCount(myArglist); + return TCL_ERROR; + } + Tcl_DecrRefCount(myArglist); + return TCL_OK; +} + +/* + * Tko_WidgetCreate -- + * Create new tko object. + * A check on the correct name of the object should be done in the calling function. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Can create new widget. + */ +int +Tko_WidgetCreate( + ClientData clientdata, /* pointer to Tko_Widget structure */ + Tcl_Interp * interp, + Tcl_Object object, + Tko_WidgetCreateMode createmode, /* */ + Tcl_Obj *arglist) /* -value option .. list, used options will be removed */ +{ + Tko_Widget *widget; + char *nsPtr; + int argSize; + Tcl_Obj *classObj; + Tcl_Obj *optionList; + Tcl_Obj *tmpObj; + Tcl_Obj **optionObjv; + int optionObjc; + Tcl_Obj **argObjv; + int argObjc; + int index = 0; /* Index in option list */ + int ret; + Tcl_Obj *value; + Tcl_Obj *screen; + char *ch; + int length; + Tcl_Obj *tmpPtr; + int initmode=1;/* 1=own widget 2=wrapped widget */ + Tk_Window wrapWin = NULL;/* needed in error case */ + TkoThreadData *tkoPtr = (TkoThreadData *)Tcl_GetThreadData(&tkoKey, sizeof(TkoThreadData)); + + /* This would be an internal programming error */ + if (clientdata == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("no widget data")); + return TCL_ERROR; + } + /* Check name starting with "::" */ + if ((tmpPtr = Tcl_GetObjectName(interp, object)) == NULL + || (ch = TclGetStringFromObj(tmpPtr, &length)) == NULL + || length < 3 || ch[0] != ':' || ch[1] != ':') { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("no object")); + return TCL_ERROR; + } + + /* Add widget to metadata so it can be released */ + Tcl_ObjectSetMetadata(object, &tkoWidgetMeta, clientdata); + + /* + * Initialize internal widget strucure. + */ + widget = (Tko_Widget *)clientdata; + widget->interp = interp; + widget->object = object; + widget->optionsTable = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + Tcl_InitHashTable(widget->optionsTable, TCL_ONE_WORD_KEYS); + widget->widgetCmd = Tcl_GetObjectCommand(object); + /* Create option array variable */ + nsPtr = Tcl_GetObjectNamespace(object)->fullName; + widget->optionsArray = Tcl_ObjPrintf("%s::tko", nsPtr); + Tcl_IncrRefCount(widget->optionsArray); + /* Create my command */ + widget->myCmd = Tcl_ObjPrintf("%s::my", nsPtr); + Tcl_IncrRefCount(widget->myCmd); + + if (createmode == TKO_CREATE_WRAP) { + wrapWin = widget->tkWin; + widget->tkWin = NULL; + } + + /* + * Get options from outermost class. + */ + classObj = Widget_GetClassName(interp, object); + if (classObj == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("no class name")); + goto error; + } + optionList = Tcl_ObjGetVar2(interp, tkoPtr->Obj_tko__option, classObj, TCL_GLOBAL_ONLY); + if (optionList == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("no option definitions")); + goto error; + } + if (Tcl_ListObjGetElements(interp, optionList, &optionObjc, &optionObjv) != TCL_OK + || optionObjc % 2 != 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrong option definitions")); + goto error; + } + + /* Convert argument list in dictionary */ + if (Tcl_DictObjSize(interp, arglist, &argSize) != TCL_OK) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not get arglist")); + goto error; + } + + /* + * Do some initialization depending on the given createmode. + */ + switch (createmode) { + case TKO_CREATE_CLASS: + widget->tkWin = NULL; + break; + case TKO_CREATE_TOPLEVEL: + /* Check name starting with "::." */ + if (ch[2] != '.') { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrong pathName: %s", ch)); + goto error; + } + if (optionObjc < 2) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("missing option definitions")); + goto error; + } + /* The "-screen" option definition should be the first option in toplevels. */ + screen = NULL; + /* -screen option should be first */ + if (strncmp("-screen", Tcl_GetString(optionObjv[0]), 8) != 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("missing -screen option")); + goto error; + } + /* we only check argument number and assume readonly flag */ + if (Tcl_ListObjGetElements(interp, optionObjv[1], &argObjc, &argObjv) != TCL_OK + || argObjc != 4) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrong -screen option")); + goto error; + } + /* Try to get value from command line or use default one. */ + Tcl_DictObjGet(interp, arglist, tkoPtr->Obj__screen, &screen); + if (screen != NULL) { + Tcl_DictObjRemove(interp, arglist, tkoPtr->Obj__screen); + argSize--; + } + else { + screen = argObjv[2]; + } + Tcl_IncrRefCount(screen); + widget->tkWin = Tk_CreateWindowFromPath(interp, Tk_MainWindow(interp), &ch[2], + Tcl_GetString(screen)); + if (widget->tkWin == NULL) { + goto error; + } + Tk_MakeWindowExist(widget->tkWin); + if ((widget->display = Tk_Display(widget->tkWin))==NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not get display")); + goto error; + } + /* When creating toplevels then check on "-screen" as first option. */ + ret = WidgetOptionAdd(interp, widget, optionObjv[0], argObjv[0], + argObjv[1], argObjv[2], argObjv[3], screen, initmode); + Tcl_DecrRefCount(screen); + if (ret != TCL_OK) { + goto error; + } + index = 2; + break; + case TKO_CREATE_WIDGET: + /* Check name starting with "::." */ + if (ch[2] != '.') { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrong pathName: %s", ch)); + goto error; + } + widget->tkWin = Tk_CreateWindowFromPath(interp, Tk_MainWindow(interp), &ch[2], + NULL); + if (widget->tkWin == NULL) { + goto error; + } + Tk_MakeWindowExist(widget->tkWin); + if ((widget->display = Tk_Display(widget->tkWin))==NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not get display")); + goto error; + } + if (optionObjc < 1) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("empty option definitions")); + goto error; + } + break; + case TKO_CREATE_WRAP: + if (wrapWin == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrap widget not found")); + goto error; + } + /* Check name starting with "::." */ + if (ch[2] != '.') { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrong pathName: %s", ch)); + goto error; + } + /* Set tko(..) to name of hidden widget */ + tmpObj = Tcl_ObjPrintf("::tko::%s", &ch[2]); + Tcl_IncrRefCount(tmpObj); + if (Tcl_ObjSetVar2(interp, widget->optionsArray, tkoPtr->Obj_point2, + tmpObj, TCL_GLOBAL_ONLY) == NULL) { + Tcl_DecrRefCount(tmpObj); + goto error; + } + Tcl_DecrRefCount(tmpObj); + if ((widget->display = Tk_Display(wrapWin))==NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("could not get display")); + goto error; + } + widget->tkWin = wrapWin; + wrapWin = NULL; + initmode = 2; + break; + default: + Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrong internal create mode")); + goto error; + } + /* Set tko(.) to name of widget or class */ + if (Tcl_ObjSetVar2(interp, widget->optionsArray, tkoPtr->Obj_point, + Tcl_NewStringObj(&ch[2], length - 2), TCL_GLOBAL_ONLY) == NULL) { + goto error; + } + + /* + * When creating widgets then "-class" option should be first option now. + * It's value is needed to get option informations from option database. + */ + if (createmode == TKO_CREATE_TOPLEVEL || createmode == TKO_CREATE_WIDGET) { + ch = Tcl_GetStringFromObj(optionObjv[index], &length); + if (strncmp(ch, "-class", length) != 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("missing -class option")); + goto error; + } + } + /* + * Add options. + */ + for(; index < optionObjc; index=index+2) { + if (Tcl_ListObjGetElements(interp, optionObjv[index+1], &argObjc, &argObjv) !=TCL_OK + || argObjc < 1 || argObjc > 4) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrong option def: %s {%s}", + Tcl_GetString(optionObjv[index]),Tcl_GetString(optionObjv[index+1]))); + goto error; + } + Tcl_DictObjGet(interp, arglist, optionObjv[index], &value); + if(value) { + Tcl_IncrRefCount(value); + Tcl_DictObjRemove(interp, arglist, optionObjv[index]); + argSize--; + } + switch (argObjc) { + case 2: /* synonym flags */ + ret = WidgetOptionAdd(interp, widget, optionObjv[index], argObjv[0], + NULL, NULL, argObjv[1], value, initmode); + break; + case 4: /* dbname dbclass default flags */ + ret = WidgetOptionAdd(interp, widget, optionObjv[index], argObjv[0], + argObjv[1], argObjv[2], argObjv[3], value, initmode); + break; + } + if (value) { + Tcl_DecrRefCount(value); + } + if (ret != TCL_OK) goto error; + } + if(argSize) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unknown options: %s", + Tcl_GetString(arglist))); + goto error; + } + + Tcl_TraceVar2(interp, Tcl_GetString(widget->optionsArray), NULL, + TCL_TRACE_WRITES | TCL_TRACE_RESULT_OBJECT, WidgetOptionTrace, widget); + + if (widget->tkWin) { + Tk_CreateEventHandler(widget->tkWin, StructureNotifyMask | VirtualEventMask, + WidgetEventProc, (ClientData)widget); + } + + return TCL_OK; + +error: + if (wrapWin) { + tmpObj = Tcl_ObjPrintf("rename ::tko::%s {}", &ch[2]); + Tcl_IncrRefCount(tmpObj); + Tcl_EvalObjEx(interp, tmpObj, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(tmpObj); + } + Tcl_DeleteCommandFromToken(interp, widget->widgetCmd); + return TCL_ERROR; +} + +/* + * Tko_WidgetDestroy -- + * Delete widget window and command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Delete widget ressources and remove widget window. + */ +void +Tko_WidgetDestroy( + Tcl_ObjectContext context) +{ + Tko_Widget *widget; + + if ((widget = (Tko_Widget *)Tko_WidgetClientData(context)) == NULL) { + return; + } + Tcl_Preserve(widget); + if (widget->tkWin) { + WidgetDeleteTkwin(widget); + } + if (widget->myCmd) { + Tcl_DecrRefCount(widget->myCmd); + widget->myCmd = NULL; + } + Tcl_ObjectSetMetadata(widget->object, &tkoWidgetMeta, NULL); + Tcl_Release(widget); + return; +} + +/* +* Tko_WidgetClientData -- +* Return pointer to widget client data. +* +* Results: +* None. +* +* Side effects: +* None. +*/ +ClientData Tko_WidgetClientData( + Tcl_ObjectContext context) +{ + Tcl_Object object; + if ((object = Tcl_ObjectContextObject(context)) == NULL) { + return NULL; + } + return Tcl_ObjectGetMetadata(object, &tkoWidgetMeta); +} + +/* + * WidgetMetaDestroy -- + * Free ressources. + * + * Results: + * None. + * + * Side effects: + * Delete or give back all used internal ressources + */ +static void +WidgetMetaDestroy( + Tko_Widget * widget) +{ + Tcl_HashSearch search; + Tcl_HashEntry *entryPtr; + + entryPtr = Tcl_FirstHashEntry(widget->optionsTable, &search); + while (entryPtr != NULL) { + WidgetOptionDelEntry(entryPtr); + entryPtr = Tcl_NextHashEntry(&search); + } + if (widget->optionsTable) { + Tcl_DeleteHashTable(widget->optionsTable); + ckfree(widget->optionsTable); + } + if (widget->optionsArray != NULL) { + Tcl_DecrRefCount((widget->optionsArray)); + widget->optionsArray = NULL; + } + ckfree(widget); +} + +/* +* WidgetDeleteTkwin -- +* Resets internal Tk_Window in widget structure. +* +* Results: +* None. +* +* Side effects: +* Delete event handler of widget. +* When the widget is wrappen then delete wrap widget command. +*/ +static void WidgetDeleteTkwin( + Tko_Widget *widget) +{ + Tcl_Obj *tmpObj; + TkoThreadData *tkoPtr = (TkoThreadData *)Tcl_GetThreadData(&tkoKey, sizeof(TkoThreadData)); + Tk_DeleteEventHandler(widget->tkWin, StructureNotifyMask | VirtualEventMask, + WidgetEventProc, widget); + tmpObj = Tcl_ObjGetVar2(widget->interp, widget->optionsArray, tkoPtr->Obj_point2, TCL_GLOBAL_ONLY); + if (tmpObj) { + tmpObj = Tcl_ObjPrintf("rename %s {}", Tcl_GetString(tmpObj)); + Tcl_IncrRefCount(tmpObj); + Tcl_EvalObjEx(widget->interp, tmpObj,TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(tmpObj); + } + else { + Tk_DestroyWindow(widget->tkWin); + } + widget->tkWin = NULL; +} + +/* +* WidgetEventProc -- +* This function is invoked by the Tk dispatcher for various events on +* canvases. +* +* Results: +* None. +* +* Side effects: +* When the window gets deleted, internal structures get cleaned up. +*/ +static void +WidgetEventProc( + ClientData clientData, /* Information about window. */ + XEvent * eventPtr) +{ /* Information about event. */ + Tko_Widget *widget = (Tko_Widget *)clientData; + + switch (eventPtr->type) { + case DestroyNotify: + if (widget->tkWin) { + WidgetDeleteTkwin(widget); + Tcl_DeleteCommandFromToken(widget->interp, widget->widgetCmd); + } + if (widget->myCmd) { + Tcl_DecrRefCount(widget->myCmd); + widget->myCmd = NULL; + } + break; + case VirtualEvent: + if (widget->tkWin) { + if (!strcmp("TkoEventOption", ((XVirtualEvent *)(eventPtr))->name)) { + WidgetEventChanged(widget); + } + } + } +} + +/* +* WidgetEventChanged -- +* Reset all option with no TKO_OPTION_USER bit from option database. +* canvases. +* +* Results: +* None. +* +* Side effects: +* Apply changed option database values. +*/ +static void +WidgetEventChanged( + Tko_Widget *widget) +{ + Tcl_HashSearch search; + Tcl_HashEntry *entryPtr; + WidgetOption *optionPtr; + Tk_Uid valueUid; + Tk_Uid dbnameUid; + Tk_Uid dbclassUid; + int changed; + Tcl_Obj *defvalue; + Tcl_Obj *myObjv[2]; + TkoThreadData *tkoPtr = (TkoThreadData *)Tcl_GetThreadData(&tkoKey, sizeof(TkoThreadData)); + + if (widget->myCmd == NULL) return; + Tcl_Preserve(widget); + entryPtr = Tcl_FirstHashEntry(widget->optionsTable, &search); + changed = 0; + while (entryPtr != NULL) { + optionPtr = (WidgetOption *)Tcl_GetHashValue(entryPtr); + entryPtr = Tcl_NextHashEntry(&search); + if (optionPtr->dbclass == NULL) continue;/* synonym option */ + if (optionPtr->dbname == tkoPtr->Obj_empty && optionPtr->dbclass == tkoPtr->Obj_empty) continue; + if (optionPtr->flagbits & TKO_OPTION_READONLY) continue;/* readonly option */ + if (optionPtr->flagbits & TKO_OPTION__USER) continue;/* user changed option */ + /* + * Get value from option database or + * check for a system-specific default value. + */ + dbnameUid = Tk_GetUid(Tcl_GetString(optionPtr->dbname)); + dbclassUid = Tk_GetUid(Tcl_GetString(optionPtr->dbclass)); + if ((valueUid = Tk_GetOption(widget->tkWin, dbnameUid, dbclassUid)) != NULL) { + defvalue = Tcl_NewStringObj(valueUid, -1); + } + else { + defvalue = Tk_GetSystemDefault(widget->tkWin, dbnameUid, dbclassUid); + if (defvalue == NULL) continue; + } + Tcl_IncrRefCount(defvalue); + /* No need to set same value again */ + if (strcmp(Tcl_GetString(defvalue), Tcl_GetString(optionPtr->value)) == 0) { + Tcl_DecrRefCount(defvalue); + continue; + } + /* Set new value */ + if (WidgetOptionSet(widget->interp, widget, optionPtr->option, defvalue) != TCL_OK) { + Tcl_DecrRefCount(defvalue); + optionPtr->flagbits &= ~TKO_OPTION__USER;/* reset option */ + continue; /* no additional error handling here */ + } + Tcl_DecrRefCount(defvalue); + changed++; + } + if (changed) { + myObjv[0] = widget->myCmd; + myObjv[1] = tkoPtr->Obj__tko_configure; + if (Tcl_EvalObjv(widget->interp, 2, myObjv, TCL_EVAL_GLOBAL) != TCL_OK) { + /* ignore errors */ + } + } + Tcl_Release(widget); +} + +/* + * WidgetMethod_cget -- + * Tcl syntax: "widget cget -option". + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Return option value in interpreter result. + */ +static int +WidgetMethod_cget( + ClientData dummy, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + Tko_Widget *widget; /* widget. */ + int skip; + (void)dummy; + + if ((widget = (Tko_Widget *)Tko_WidgetClientData(context)) == NULL + || widget->myCmd == NULL) { + return TCL_ERROR; + } + skip = Tcl_ObjectContextSkippedArgs(context); + + if(objc - skip != 1) { + Tcl_WrongNumArgs(interp, skip, objv, "option"); + return TCL_ERROR; + } + return WidgetOptionGet(interp, widget, objv[skip]); +} + +/* + * WidgetMethod_configure -- + * Tcl syntax: + * configure + * configure "-option" + * configure "-option value .." + * configure "add option dbname dbclass ?default?" + * configure "del option" + * configure "after" + * Changing of option values: + * 1. set tk(-option) + * 2. WidgetTraceOption() + * 3. "my -option $v .." + * + * Results: + * A standard Tcl result. Return result value in interpreter result. + * + * Side effects: + * Can add, delete or change options. + */ +static int +WidgetMethod_configure( + ClientData dummy, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + Tko_Widget *widget; /* widget. */ + int skip; + Tcl_Obj *myObjv[2]; + Tcl_HashSearch search; + Tcl_HashEntry *entryPtr; + WidgetOption *optionPtr; + Tcl_Obj *retPtr; + Tcl_Obj *listPtr; + const char *ch; + int length; + int i; + TkoThreadData *tkoPtr = (TkoThreadData *)Tcl_GetThreadData(&tkoKey, sizeof(TkoThreadData)); + (void)dummy; + + if ((widget = (Tko_Widget *)Tko_WidgetClientData(context)) == NULL + || widget->myCmd == NULL) { + return TCL_ERROR; + } + skip = Tcl_ObjectContextSkippedArgs(context); + + /* configure */ + if(objc - skip == 0) { + retPtr = Tcl_NewObj(); + entryPtr = Tcl_FirstHashEntry(widget->optionsTable, &search); + while(entryPtr != NULL) { + optionPtr = (WidgetOption *) Tcl_GetHashValue(entryPtr); + entryPtr = Tcl_NextHashEntry(&search); + /* hidden option, not visible in configure method */ + if (optionPtr->flagbits&TKO_OPTION_HIDE) continue; + listPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(interp, listPtr, optionPtr->option); + Tcl_ListObjAppendElement(interp, listPtr, optionPtr->dbname); + if (optionPtr->dbclass != NULL) { + Tcl_ListObjAppendElement(interp, listPtr, optionPtr->dbclass); + Tcl_ListObjAppendElement(interp, listPtr, optionPtr->defvalue); + Tcl_ListObjAppendElement(interp, listPtr, optionPtr->value); + } + Tcl_ListObjAppendElement(interp, retPtr, listPtr); + } + /* Return sorted list */ + myObjv[0] = tkoPtr->Obj_lsort; + myObjv[1] = retPtr; + return (Tcl_EvalObjv(interp, 2, myObjv, TCL_EVAL_GLOBAL)); + } + /* configure "-option ?value? .." */ + if(objc - skip == 1) { /* configure -option */ + ch = Tcl_GetStringFromObj(objv[skip],&length); + /* configure . */ + if(ch[0] == '.' && length == 1) { + // collect all not readonly options and configure + Tcl_Preserve(widget); + myObjv[0] = widget->myCmd; + entryPtr = Tcl_FirstHashEntry(widget->optionsTable, &search); + while (entryPtr != NULL) { + optionPtr = (WidgetOption *)Tcl_GetHashValue(entryPtr); + entryPtr = Tcl_NextHashEntry(&search); + if (optionPtr->dbclass == NULL) { /* synonym option */ + if (optionPtr->value) { + Tcl_ObjSetVar2(interp, widget->optionsArray, + optionPtr->dbname, optionPtr->value, TCL_GLOBAL_ONLY); + Tcl_DecrRefCount(optionPtr->value); + optionPtr->value = NULL; + } + } + else { /* normal option */ + if ((optionPtr->flagbits & TKO_OPTION_READONLY) == 0) { + myObjv[1] = optionPtr->option; + if (Tcl_EvalObjv(interp, 2, myObjv, + TCL_EVAL_GLOBAL) != TCL_OK) { + retPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(retPtr); + Tcl_Release(widget); + Tcl_DeleteCommandFromToken(interp, widget->widgetCmd); + Tcl_SetObjResult(interp, retPtr); + Tcl_DecrRefCount(retPtr); + return TCL_ERROR; + } + } + } + } + myObjv[1] = tkoPtr->Obj__tko_configure; + if (Tcl_EvalObjv(interp, 2, myObjv, TCL_EVAL_GLOBAL) != TCL_OK) { + retPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(retPtr); + Tcl_Release(widget); + Tcl_DeleteCommandFromToken(interp, widget->widgetCmd); + Tcl_SetObjResult(interp, retPtr); + Tcl_DecrRefCount(retPtr); + return TCL_ERROR; + } + Tcl_Release(widget); + Tcl_SetObjResult(interp, Tcl_ObjGetVar2(interp, widget->optionsArray, tkoPtr->Obj_point, TCL_GLOBAL_ONLY)); + return TCL_OK; + } + entryPtr = + Tcl_FindHashEntry(widget->optionsTable, + Tk_GetUid(Tcl_GetString(objv[skip]))); + if(entryPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unknown option \"%s\"", + Tcl_GetString(objv[skip]))); + return TCL_ERROR; + } + optionPtr = (WidgetOption *) Tcl_GetHashValue(entryPtr); + /* hidden option, not visible in configure method */ + if (optionPtr->flagbits&TKO_OPTION_HIDE) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("hidden option \"%s\"", + Tcl_GetString(objv[skip]))); + return TCL_ERROR; + } + if (optionPtr->dbclass == NULL) { + entryPtr = + Tcl_FindHashEntry(widget->optionsTable, + Tk_GetUid(Tcl_GetString(optionPtr->dbname))); + if(entryPtr == NULL) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("unknown option \"%s\"", + Tcl_GetString(objv[skip]))); + return TCL_ERROR; + } + optionPtr = (WidgetOption *) Tcl_GetHashValue(entryPtr); + if(optionPtr->dbclass == NULL) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("unknown option \"%s\"", + Tcl_GetString(objv[skip]))); + return TCL_ERROR; + } + } + listPtr = Tcl_NewObj(); + Tcl_ListObjAppendElement(interp, listPtr, optionPtr->option); + Tcl_ListObjAppendElement(interp, listPtr, optionPtr->dbname); + Tcl_ListObjAppendElement(interp, listPtr, optionPtr->dbclass); + if (optionPtr->defvalue) { + Tcl_ListObjAppendElement(interp, listPtr, optionPtr->defvalue); + } + else { + Tcl_ListObjAppendElement(interp, listPtr, tkoPtr->Obj_empty); + } + Tcl_ListObjAppendElement(interp, listPtr, optionPtr->value); + Tcl_SetObjResult(interp, listPtr); + return TCL_OK; + } + /* configure "-option ?value? .." */ + if((objc - skip) % 2 == 0) { + Tcl_Preserve(widget); + for (i = skip; i < objc; i = i + 2) { + if (WidgetOptionSet(interp, widget, objv[i], objv[i + 1]) != TCL_OK) { + Tcl_Release(widget); + return TCL_ERROR; + } + } + myObjv[0] = widget->myCmd; + myObjv[1] = tkoPtr->Obj__tko_configure; + if (Tcl_EvalObjv(interp, 2, myObjv, TCL_EVAL_GLOBAL) != TCL_OK) { + Tcl_Release(widget); + return TCL_ERROR; + } + Tcl_Release(widget); + return TCL_OK; + } + Tcl_WrongNumArgs(interp, skip, objv, "?-option value ..?"); + return TCL_ERROR; +} + +/* + * WidgetOptionAdd -- + * Add a new option to a created widget. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Add and initialize the new option. + */ +static int +WidgetOptionAdd( + Tcl_Interp * interp, /* used interpreter */ + Tko_Widget * widget, /* currrent widget or NULL if only checks should be done */ + Tcl_Obj * option, /* name of option, always given*/ + Tcl_Obj * dbname, /* dbname or synonym, always given */ + Tcl_Obj * dbclass, /* dbclass or NULL if synonym option */ + Tcl_Obj * defvalue, /* default value of option */ + Tcl_Obj * flags, /* value or NULL if synonym option */ + Tcl_Obj * value, /* initialization value */ + int initmode) /* 0 when adding to existing object, 1 when constructor, 2 when wrapped widget */ +{ + Tcl_HashEntry *entryPtr; + WidgetOption *optionPtr; + Tk_Uid valueUid; + int isNew; + Tk_Uid optionUid; + Tk_Uid dbnameUid; + Tk_Uid dbclassUid; + int intFlags; + int readonly; + Tcl_Obj *myObjv[2]; + const char *ch; + const char *opt; + int traceadd = 0; /* if not 0 then readd trace on array variable */ + int searchdb = 0; /* search optiondb for values */ + TkoThreadData *tkoPtr = (TkoThreadData *)Tcl_GetThreadData(&tkoKey, sizeof(TkoThreadData)); + + if((opt=Tcl_GetString(option))[0] != '-') { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("wrong option: %s", opt)); + return TCL_ERROR; + } + /* synonym option check */ + if(dbclass == NULL) { + if((ch=Tcl_GetString(dbname))[0] != '-' || ch[1]=='\0') { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("wrong synonym: %s %s", opt, ch)); + return TCL_ERROR; + } + } + /* int flag */ + intFlags = 0; + if (flags && WidgetFlagsObj(flags,&intFlags) != TCL_OK) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("wrong flags: %s %s",opt,Tcl_GetString(flags))); + return TCL_ERROR; + } + if (intFlags & TKO_OPTION_READONLY) { + intFlags &= ~TKO_OPTION_READONLY; + readonly = TKO_OPTION_READONLY; + } + else { + readonly = 0; + } + /* return if no widget given, all class checks are done */ + if(widget == NULL) { + return TCL_OK; + } + optionUid = Tk_GetUid(opt); + entryPtr = Tcl_CreateHashEntry(widget->optionsTable, optionUid, &isNew); + if(isNew == 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("option exists: %s", opt)); + return TCL_ERROR; + } + /* create option */ + optionPtr = (WidgetOption *)ckalloc(sizeof(WidgetOption)); + assert(optionPtr); + memset(optionPtr, 0, sizeof(WidgetOption)); + optionPtr->option = option; + Tcl_IncrRefCount(optionPtr->option); + if (Tcl_GetString(dbname)[0] == '\0') { + optionPtr->dbname = tkoPtr->Obj_empty; + searchdb++; + } + else { + optionPtr->dbname = dbname; + } + Tcl_IncrRefCount(optionPtr->dbname); + Tcl_SetHashValue(entryPtr, (char *)optionPtr); + if (flags) { + optionPtr->flags = flags; + } + else { + optionPtr->flags = tkoPtr->Obj_empty; + } + Tcl_IncrRefCount(optionPtr->flags); + optionPtr->flagbits = intFlags; + /* synonym options can have flags. + * Need to check usage of init value! */ + if(dbclass == NULL) { + optionPtr->dbclass = NULL; + optionPtr->defvalue = NULL; + if(value) { + optionPtr->value = value; + Tcl_IncrRefCount(optionPtr->value); + } + /* normal option */ + } else { + if (Tcl_GetString(dbclass)[0] == '\0') { + optionPtr->dbclass = tkoPtr->Obj_empty; + dbclassUid = tkoPtr->Uid_empty; + searchdb++; + } + else { + dbclassUid = Tk_GetUid(Tcl_GetString(dbclass)); + optionPtr->dbclass = dbclass; + } + Tcl_IncrRefCount(optionPtr->dbclass); + + optionPtr->defvalue = defvalue; + Tcl_IncrRefCount(optionPtr->defvalue); + + /* + * If value is given use it. + */ + if(value) { + optionPtr->value = value; + optionPtr->flagbits |= TKO_OPTION__USER; + } else { + if (searchdb < 2 && widget->tkWin != NULL) { + /* + * Get value from option database + */ + dbnameUid = Tk_GetUid(Tcl_GetString(dbname)); + if (optionPtr->value == NULL) { + valueUid = Tk_GetOption(widget->tkWin, dbnameUid, dbclassUid); + if (valueUid != NULL) { + optionPtr->value = Tcl_NewStringObj(valueUid, -1); + } + } + /* + * Check for a system-specific default value. + * Do not for -class because Tcl_SetClass was not called. + * When -class is not first option (after -screen) we get a crash! + */ + if (optionPtr->value == NULL && optionUid != tkoPtr->Uid_class) { + optionPtr->value = + Tk_GetSystemDefault(widget->tkWin, dbnameUid, dbclassUid); + } + } + /* + * Use default value. + */ + if(optionPtr->value == NULL) { + optionPtr->value = defvalue; + optionPtr->flagbits |= TKO_OPTION__USER; + } + } + /* + * No given value defaults to empty string. + */ + if(optionPtr->value == NULL) { + optionPtr->value = tkoPtr->Obj_empty; + /* No flag as this does not count as user supplied */ + } + Tcl_IncrRefCount(optionPtr->value); + /* + * Outside initmode the trace on the array variable needs to be disabled. + */ + if (initmode == 0) { + Tcl_UntraceVar2(interp, Tcl_GetString(widget->optionsArray), NULL, + TCL_TRACE_WRITES | TCL_TRACE_RESULT_OBJECT, WidgetOptionTrace, widget); + traceadd = 1; + } + /* + *Set option array variable + */ + if (Tcl_ObjSetVar2(interp, widget->optionsArray, option, + optionPtr->value, TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) { + goto error; + } + /* + * Do initialization with -option method. + * We do it for readonly options only here. + * And we do it for options added with "configure optionadd ..". + */ + if (readonly || initmode == 0) { + if (initmode != 2) { + myObjv[0] = widget->myCmd; + myObjv[1] = option; + if (Tcl_EvalObjv(interp, 2, myObjv, TCL_EVAL_GLOBAL) != TCL_OK) { + goto error; + } + /* + * We set the value again because the -option method may have changed it. + */ + if (optionPtr->value) { + Tcl_DecrRefCount(optionPtr->value); + } + optionPtr->value = Tcl_ObjGetVar2(interp, widget->optionsArray, option, TCL_GLOBAL_ONLY); + Tcl_IncrRefCount(optionPtr->value); + } + /* Now we are ready to set the readonly bit */ + if (readonly) { + optionPtr->flagbits |= TKO_OPTION_READONLY; + } + } + } + if (traceadd) { + Tcl_TraceVar2(interp, Tcl_GetString(widget->optionsArray), NULL, + TCL_TRACE_WRITES | TCL_TRACE_RESULT_OBJECT, WidgetOptionTrace, widget); + } + return TCL_OK; +error: + if (traceadd) { + /* There should be no error and thus we don't need to save the result. */ + Tcl_TraceVar2(interp, Tcl_GetString(widget->optionsArray), NULL, + TCL_TRACE_WRITES | TCL_TRACE_RESULT_OBJECT, WidgetOptionTrace, widget); + } + WidgetOptionDelEntry(entryPtr); + return TCL_ERROR; +} + +/* + * WidgetOptionGet -- + * Get option value. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * return current vlaue of widget option. + */ +static int +WidgetOptionGet( + Tcl_Interp * interp, + Tko_Widget * widget, + Tcl_Obj * option) +{ + Tcl_Obj *retPtr; + Tcl_HashEntry *entryPtr; + WidgetOption *optionPtr; + + if(option == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("no option given")); + return TCL_ERROR; + } + entryPtr = + Tcl_FindHashEntry(widget->optionsTable, + Tk_GetUid(Tcl_GetString(option))); + if(entryPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unknown option \"%s\"", + Tcl_GetString(option))); + return TCL_ERROR; + } + optionPtr = (WidgetOption *)Tcl_GetHashValue(entryPtr); + /* hidden option, not visible in cget method */ + if (optionPtr->flagbits&TKO_OPTION_HIDE) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("hidden option \"%s\"", + Tcl_GetString(option))); + return TCL_ERROR; + } + /* synonym option */ + if(optionPtr->dbclass == NULL) { + entryPtr = + Tcl_FindHashEntry(widget->optionsTable, + Tk_GetUid(Tcl_GetString(optionPtr->dbname))); + if(entryPtr == NULL) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("unknown synonym option \"%s\"", + Tcl_GetString(option))); + return TCL_ERROR; + } + optionPtr = (WidgetOption *)Tcl_GetHashValue(entryPtr); + if(optionPtr->dbclass == NULL) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("synonym option is synonym \"%s\"", + Tcl_GetString(option))); + return TCL_ERROR; + } + } + retPtr = optionPtr->value; + Tcl_SetObjResult(interp, retPtr); + return TCL_OK; +} + +/* + * WidgetOptionSet -- + * Set new widget option value. + * Results: + * A standard Tcl result. + * + * Side effects: + * Set option value and call + */ +static int +WidgetOptionSet( + Tcl_Interp * interp, + Tko_Widget * widget, + Tcl_Obj * option, + Tcl_Obj * value) +{ + Tcl_HashEntry *entryPtr; + WidgetOption *optionPtr; + + if(option == NULL || value == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("missing option and/or value")); + return TCL_ERROR; + } + entryPtr = + Tcl_FindHashEntry(widget->optionsTable, + Tk_GetUid(Tcl_GetString(option))); + if(entryPtr == NULL) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("unknown option \"%s\"", Tcl_GetString(option))); + return TCL_ERROR; + } + optionPtr = (WidgetOption *)Tcl_GetHashValue(entryPtr); + /* hidden option, not visible in cget method */ + if (optionPtr->flagbits&TKO_OPTION_HIDE) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("hidden option \"%s\"", + Tcl_GetString(option))); + return TCL_ERROR; + } + /* synonym option */ + if(optionPtr->dbclass == NULL) { + entryPtr = + Tcl_FindHashEntry(widget->optionsTable, + Tk_GetUid(Tcl_GetString(optionPtr->dbname))); + if(entryPtr == NULL) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("unknown synonym option \"%s\"", + Tcl_GetString(option))); + return TCL_ERROR; + } + optionPtr = (WidgetOption *)Tcl_GetHashValue(entryPtr); + if(optionPtr->dbclass == NULL) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("synonym option is synonym \"%s\"", + Tcl_GetString(option))); + return TCL_ERROR; + } + if(Tcl_ObjSetVar2(interp, widget->optionsArray, optionPtr->option, + value, TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + } else { + if(Tcl_ObjSetVar2(interp, widget->optionsArray, option, value, + TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG) == NULL) { + return TCL_ERROR; + } + } + optionPtr->flagbits |= TKO_OPTION__USER; + return TCL_OK; +} + +/* +* Tko_WidgetOptionGet -- +* +* Results: +* Return TclObj value of option or NULL if widget is destroyed. +* +* Side effects: +*/ +Tcl_Obj * +Tko_WidgetOptionGet( + Tko_Widget *widget, + Tcl_Obj *option) +{ + if (widget->optionsArray == NULL || option ==NULL) return NULL; + return Tcl_ObjGetVar2(widget->interp, widget->optionsArray, option, + TCL_GLOBAL_ONLY); +} + +/* + * Tko_WidgetOptionSet -- + * Set option value. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Create necessary C-values. + */ +Tcl_Obj * +Tko_WidgetOptionSet( + Tko_Widget *widget, + Tcl_Obj * option, + Tcl_Obj * value) +{ + if (widget->optionsArray == NULL || option==NULL || value == NULL) return NULL; + return Tcl_ObjSetVar2(widget->interp, widget->optionsArray, option, value, + TCL_GLOBAL_ONLY); +} + +/* + * WidgetOptionTrace -- + * Write trace on option array variable + * + * Results: + * Return NULL if successfull and leave error message otherwise. + * + * Side effects: + * Check on existence of option and call "-option" method with new value. + */ +static char * +WidgetOptionTrace( + ClientData clientData, + Tcl_Interp * interp, + const char *name1, + const char *name2, + int flags) +{ + Tko_Widget *widget = (Tko_Widget *) clientData; + Tcl_HashEntry *entryPtr; + Tcl_Obj *valuePtr; + // const char *result; + WidgetOption *optionPtr; + Tcl_Obj *myObjv[2]; + Tcl_Obj *myRet; + (void)name1; + (void)flags; + + /* get new value */ + entryPtr = Tcl_FindHashEntry(widget->optionsTable, Tk_GetUid(name2)); + if(entryPtr == NULL) { + myRet = Tcl_ObjPrintf("option \"%s\" not found", name2); + Tcl_IncrRefCount(myRet); + return (char *)myRet; + } + optionPtr = (WidgetOption *) Tcl_GetHashValue(entryPtr); + if(optionPtr->flagbits & TKO_OPTION_READONLY) { + myRet = Tcl_ObjPrintf("option \"%s\" is readonly", name2); + Tcl_IncrRefCount(myRet); + return (char *)myRet; + } + myObjv[0] = widget->myCmd; + myObjv[1] = optionPtr->option; + if(Tcl_EvalObjv(interp, 2, myObjv, TCL_EVAL_GLOBAL) != TCL_OK) { + myRet = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(myRet); + /* reset to old value TODO checks? */ + if(optionPtr->value != NULL) { + Tcl_ObjSetVar2(interp, widget->optionsArray, optionPtr->option, + optionPtr->value, TCL_GLOBAL_ONLY); + Tcl_EvalObjv(interp, 2, myObjv, TCL_EVAL_GLOBAL); + } + return (char *)myRet; + } + if(optionPtr->value != NULL) { + Tcl_DecrRefCount(optionPtr->value); + } + valuePtr = Tcl_ObjGetVar2(interp, widget->optionsArray, optionPtr->option, TCL_GLOBAL_ONLY); + optionPtr->value = valuePtr; + Tcl_IncrRefCount(optionPtr->value); + return NULL; +} + +/* + * WidgetOptionDelEntry -- + * Delete internal entry value. + * + * Results: + * None. + * + * Side effects: + */ +static void +WidgetOptionDelEntry( + Tcl_HashEntry * entry) +{ + WidgetOption *optionPtr = (WidgetOption *)Tcl_GetHashValue(entry); + + if(optionPtr->option) + Tcl_DecrRefCount(optionPtr->option); + if(optionPtr->dbname) + Tcl_DecrRefCount(optionPtr->dbname); + if(optionPtr->dbclass) + Tcl_DecrRefCount(optionPtr->dbclass); + if(optionPtr->flags) + Tcl_DecrRefCount(optionPtr->flags); + if(optionPtr->defvalue) + Tcl_DecrRefCount(optionPtr->defvalue); + if(optionPtr->value) + Tcl_DecrRefCount(optionPtr->value); + ckfree(optionPtr); + Tcl_DeleteHashEntry(entry); +} + +/* + * WidgetMethod_tko_configure -- + * Virtual method called after configuring options. + * Should be implemented in derived classes. + * + * Results: + * A standard Tcl result. + * + * Side effects: + */ +static int +WidgetMethod_tko_configure( + ClientData dummy, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ /* virtual method */ + (void)dummy; + (void)interp; + (void)context; + (void)objc; + (void)objv; + + return TCL_OK; +} + +/* + * WidgetMetaDelete -- + * Delete widget meta data when all preserve calls done. + * + * Results: + * None. + * + * Side effects: + */ +static void +WidgetMetaDelete( + ClientData clientData) +{ + (void)clientData; + /* Tcl_EventuallyFree(clientData, (Tcl_FreeProc *)WidgetMetaDestroy); */ +} + +/* + * WidgetMethod_ -- + * Standard option set method. + * + * Results: + * A standard Tcl result. + * + * Side effects: + */ +static int +WidgetMethod_( + ClientData clientdata, + Tcl_Interp * interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj * const objv[]) +{ + WidgetClientdata *define; + Tcl_Object object; + Tko_Widget *widget; + Tcl_Obj *value; + char *address = NULL; + int intVal; + double dblVal; + Colormap colormap; + int *intPtr; + const char *str; + int length; + int pixels[4] = { 0, 0, 0, 0 }; + int myObjc; + Tcl_Obj **myObjv; + Visual * visual; + XColor * color; + Tk_3DBorder border; + Tk_Anchor anchor; + Tk_Cursor cursor; + Tk_Window newWin; + Tk_Font newFont; + Tk_Justify justify; + (void)objc; + + if ((define = (WidgetClientdata *)clientdata) == NULL + || (object = Tcl_ObjectContextObject(context)) == NULL + || (widget = (Tko_Widget *)Tcl_ObjectGetMetadata(object, &tkoWidgetMeta)) + == NULL + || (value = Tcl_ObjGetVar2(interp, widget->optionsArray, define->option, + TCL_GLOBAL_ONLY)) == NULL + || widget->myCmd == NULL) { + return TCL_ERROR; + } + if (define->offset > 0) { + address = ((char *)widget) + define->offset; + } + + switch (define->type) { + case TKO_SET_CLASS: /* (Tcl_Obj **)address */ + Tk_SetClass(widget->tkWin, Tcl_GetString(value)); + if (address) { + if (*((Tcl_Obj **)address) != NULL) + Tcl_DecrRefCount(*((Tcl_Obj **)address)); + *((Tcl_Obj **)address) = value; + Tcl_IncrRefCount(value); + } + return TCL_OK; + case TKO_SET_VISUAL: /* (Tcl_Obj **)address */ + visual = + Tk_GetVisual(interp, widget->tkWin, Tcl_GetString(value), &intVal, + &colormap); + if (visual == NULL) + return TCL_ERROR; + Tk_SetWindowVisual(widget->tkWin, visual, intVal, colormap); + if (address) { + if (*((Tcl_Obj **)address) != NULL) + Tcl_DecrRefCount(*((Tcl_Obj **)address)); + *((Tcl_Obj **)address) = value; + Tcl_IncrRefCount(value); + } + return TCL_OK; + case TKO_SET_COLORMAP: /* (Tcl_Obj **)address */ + str = Tcl_GetStringFromObj(value, &length); + if (str && length) { + colormap = Tk_GetColormap(interp, widget->tkWin, str); + if (colormap == None) + return TCL_ERROR; + Tk_SetWindowColormap(widget->tkWin, colormap); + } + if (address) { + if (*((Tcl_Obj **)address) != NULL) + Tcl_DecrRefCount(*((Tcl_Obj **)address)); + *((Tcl_Obj **)address) = value; + Tcl_IncrRefCount(value); + } + return TCL_OK; + case TKO_SET_USE: /* (Tcl_Obj **)address */ + str = Tcl_GetStringFromObj(value, &length); + if (str && length) { + if (Tk_UseWindow(interp, widget->tkWin, str) != TCL_OK) { + return TCL_ERROR; + } + } + else if (!(define->flags & TKO_OPTION_NULL)) { + return TCL_ERROR; + + } + if (address) { + if (*((Tcl_Obj **)address) != NULL) + Tcl_DecrRefCount(*((Tcl_Obj **)address)); + if (length) { + *((Tcl_Obj **)address) = value; + Tcl_IncrRefCount(value); + } + else { + *((Tcl_Obj **)address) = NULL; + } + } + return TCL_OK; + case TKO_SET_CONTAINER: /* (int *)address */ + if (Tcl_GetBooleanFromObj(interp, value, &intVal) != TCL_OK) + return TCL_ERROR; + if (intVal) { + Tk_MakeContainer(widget->tkWin); + Tcl_ObjSetVar2(interp, widget->optionsArray, objv[1], Tcl_NewIntObj(1), + TCL_GLOBAL_ONLY); + } + else { + Tcl_ObjSetVar2(interp, widget->optionsArray, objv[1], Tcl_NewIntObj(0), + TCL_GLOBAL_ONLY); + } + if (address) { + *(int *)address = intVal; + } + return TCL_OK; + case TKO_SET_TCLOBJ: /* (Tcl_Obj **)address */ + if (address) { + if (*((Tcl_Obj **)address) != NULL) + Tcl_DecrRefCount(*((Tcl_Obj **)address)); + *((Tcl_Obj **)address) = value; + Tcl_IncrRefCount(value); + } + return TCL_OK; + case TKO_SET_XCOLOR: /* (Xcolor **)address */ + color = Tk_AllocColorFromObj(interp, widget->tkWin, value); + if (color == NULL) + return TCL_ERROR; + if (address) { + if (*((XColor **)address) != NULL) { + Tk_FreeColor(*((XColor **)address)); + } + *((XColor **)address) = color; + } + else { + Tk_FreeColor(color); + } + return TCL_OK; + case TKO_SET_3DBORDER: /* (Tk_3DBorder *)address */ + str = Tcl_GetStringFromObj(value, &length); + if (str && length) { + border = Tk_Alloc3DBorderFromObj(interp, widget->tkWin, value); + if (border == NULL) + return TCL_ERROR; + } + else if (define->flags & TKO_OPTION_NULL) { + border = NULL; + } else { + return TCL_ERROR; + } + if (address) { + if (*(Tk_3DBorder *)address != NULL) { + Tk_Free3DBorder(*(Tk_3DBorder *)address); + } + *(Tk_3DBorder *)address = border; + } + else { + Tk_Free3DBorder(border); + } + return TCL_OK; + case TKO_SET_PIXEL: /* (int *)address */ + if (Tk_GetPixelsFromObj(interp, widget->tkWin, value, &intVal) != TCL_OK) { + return TCL_ERROR; + } + if (address) { + *(int *)address = intVal; + } + Tcl_ObjSetVar2(interp, widget->optionsArray, objv[1], + Tcl_NewIntObj(intVal), TCL_GLOBAL_ONLY); + return TCL_OK; + case TKO_SET_PIXELNONEGATIV: /* (int *)address */ + if (Tk_GetPixelsFromObj(interp, widget->tkWin, value, &intVal) != TCL_OK) { + return TCL_ERROR; + } + if (intVal >= SHRT_MAX) { + Tcl_AppendResult(interp, "bad distance \"", Tcl_GetString(value), + "\": ", "too big to represent", (char *)NULL); + return TCL_ERROR; + } + if (intVal < 0) { + Tcl_AppendResult(interp, "bad distance \"", Tcl_GetString(value), + "\": ", "can't be negative", (char *)NULL); + return TCL_ERROR; + } + if (address) { + *(int *)address = intVal; + } + Tcl_ObjSetVar2(interp, widget->optionsArray, objv[1], + Tcl_NewIntObj(intVal), TCL_GLOBAL_ONLY); + return TCL_OK; + case TKO_SET_PIXELPOSITIV: /* (int *)address */ + if (Tk_GetPixelsFromObj(interp, widget->tkWin, value, &intVal) != TCL_OK) { + return TCL_ERROR; + } + if (intVal >= SHRT_MAX) { + Tcl_AppendResult(interp, "bad distance \"", Tcl_GetString(value), + "\": ", "too big to represent", (char *)NULL); + return TCL_ERROR; + } + if (intVal <= 0) { + Tcl_AppendResult(interp, "bad distance \"", Tcl_GetString(value), + "\": ", "must be positive", (char *)NULL); + return TCL_ERROR; + } + if (address) { + *(int *)address = intVal; + } + Tcl_ObjSetVar2(interp, widget->optionsArray, objv[1], + Tcl_NewIntObj(intVal), TCL_GLOBAL_ONLY); + return TCL_OK; + case TKO_SET_DOUBLE: /* (double *)address */ + if (Tcl_GetDoubleFromObj(interp, value, &dblVal) != TCL_OK) { + return TCL_ERROR; + } + if (address) { + *(double *)address = dblVal; + } + Tcl_ObjSetVar2(interp, widget->optionsArray, objv[1], + Tcl_NewDoubleObj(dblVal), TCL_GLOBAL_ONLY); + return TCL_OK; + case TKO_SET_BOOLEAN: /* (int *)address */ + if (Tcl_GetBooleanFromObj(interp, value, &intVal) != TCL_OK) { + return TCL_ERROR; + } + if (intVal) { + Tcl_ObjSetVar2(interp, widget->optionsArray, objv[1], Tcl_NewIntObj(1), + TCL_GLOBAL_ONLY); + } + else { + Tcl_ObjSetVar2(interp, widget->optionsArray, objv[1], Tcl_NewIntObj(0), + TCL_GLOBAL_ONLY); + } + if (address) { + *(int *)address = intVal; + } + Tcl_ObjSetVar2(interp, widget->optionsArray, objv[1], + Tcl_NewIntObj(intVal), TCL_GLOBAL_ONLY); + return TCL_OK; + case TKO_SET_CURSOR: /* (Tk_Cursor *)address */ + cursor = NULL; + if (Tcl_GetString(value)[0] != '\0') { + cursor = Tk_AllocCursorFromObj(interp, widget->tkWin, value); + if (cursor == NULL) { + return TCL_ERROR; + } + Tk_DefineCursor(widget->tkWin, cursor); + } + if (address) { + if (*(Tk_Cursor *)address != NULL) { + Tk_FreeCursor(Tk_Display(widget->tkWin), + *(Tk_Cursor *)address); + } + *(Tk_Cursor *)address = cursor; + } + else { + if (cursor != NULL) { + Tk_FreeCursor(Tk_Display(widget->tkWin), cursor);/*TODO necessary? */ + } + } + return TCL_OK; + case TKO_SET_INT: /* (int *)address */ + if (Tcl_GetIntFromObj(interp, value, &intVal) != TCL_OK) { + return TCL_ERROR; + } + if (address) { + *(int *)address = intVal; + } + Tcl_ObjSetVar2(interp, widget->optionsArray, objv[1], + Tcl_NewIntObj(intVal), TCL_GLOBAL_ONLY); + return TCL_OK; + case TKO_SET_RELIEF: /* (int *)address */ + if (Tk_GetReliefFromObj(interp, value, &intVal) != TCL_OK) { + return TCL_ERROR; + } + if (address) { + *(int *)address = intVal; + } + return TCL_OK; + case TKO_SET_ANCHOR: /* (Tk_Anchor *)address */ + if (Tk_GetAnchorFromObj(interp, value, &anchor) != TCL_OK) { + return TCL_ERROR; + } + if (address) { + *(Tk_Anchor *)address = anchor; + } + return TCL_OK; + case TKO_SET_WINDOW: /* (Tk_Window *)address */ + if (value == NULL || Tcl_GetCharLength(value) == 0) { + newWin = NULL; + } + else { + if (TkGetWindowFromObj(interp, widget->tkWin, value, + &newWin) != TCL_OK) { + return TCL_ERROR; + } + } + if (address) { + *(Tk_Window *)address = newWin; + } + return TCL_OK; + case TKO_SET_FONT: /* (Tk_Font *)address */ + newFont = Tk_AllocFontFromObj(interp, widget->tkWin, value); + if (newFont == NULL) { + return TCL_ERROR; + } + if (address) { + if (*(Tk_Font *)address != NULL) { + Tk_FreeFont(*(Tk_Font *)address); + } + *(Tk_Font *)address = newFont; + } + else { + Tk_FreeFont(newFont); + } + return TCL_OK; + case TKO_SET_STRING: /* (char **)address */ + if (address) { + str = Tcl_GetStringFromObj(value, &length); + if (*(char **)address != NULL) { + ckfree(*(char **)address); + } + if (length == 0 && define->flags&TKO_OPTION_NULL) { + *(char **)address = NULL; + } + else { + *(char **)address=(char *)ckalloc(length + 1); + assert(*(char **)address); + memcpy(*(char **)address, str, length + 1); + } + } + return TCL_OK; + case TKO_SET_SCROLLREGION: /* (int *[4])address */ + if (Tcl_ListObjGetElements(interp, value, &myObjc, &myObjv) != TCL_OK) { + return TCL_ERROR; + } + if (myObjc == 4) { + if (Tk_GetPixelsFromObj(interp, widget->tkWin, myObjv[0], + &pixels[0]) != TCL_OK + || Tk_GetPixelsFromObj(interp, widget->tkWin, myObjv[1], + &pixels[1]) != TCL_OK + || Tk_GetPixelsFromObj(interp, widget->tkWin, myObjv[2], + &pixels[2]) != TCL_OK + || Tk_GetPixelsFromObj(interp, widget->tkWin, myObjv[3], + &pixels[3]) != TCL_OK) { + return TCL_ERROR; + } + } + else if (myObjc != 0) { + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("found %d instead of 4 values", myObjc)); + return TCL_ERROR; + } + if (address) { + intPtr = (int *)address; + intPtr[0] = pixels[0]; + intPtr[1] = pixels[1]; + intPtr[2] = pixels[2]; + intPtr[3] = pixels[3]; + } + return TCL_OK; + case TKO_SET_JUSTIFY: /* (Tk_Justify *)address */ + if (Tk_GetJustify(interp, Tk_GetUid(Tcl_GetString(value)), + &justify) != TCL_OK) { + return TCL_ERROR; + } + if (address) { + *(Tk_Justify *)address = justify; + } + return TCL_OK; + } + + Tcl_SetObjResult(interp, Tcl_ObjPrintf("unknown type \"%d\"", define->type)); + return TCL_ERROR; +} + +/* +* WidgetMethod_ -- +* Check given flagsPtr object and if flags is given set int value from string. +* +* Results: +* A standard Tcl result. +* +* Side effects: +*/ +static int WidgetFlagsObj(Tcl_Obj *flagsPtr, int *flags) +{ + char *ch; + int retValue = 0; + if (flagsPtr == NULL) return TCL_ERROR; + ch = Tcl_GetString(flagsPtr); + if (ch[0] != '\0') { + if (ch[0] == 'r') { + retValue |= TKO_OPTION_READONLY; + if (ch[1] != '\0') { + if (ch[1] == 'h') { + retValue |= TKO_OPTION_HIDE; + } + else { + return TCL_ERROR; + } + } + } + else if (ch[0] == 'h') { + retValue |= TKO_OPTION_HIDE; + if (ch[1] != '\0') { + if (ch[1] == 'r') { + retValue |= TKO_OPTION_READONLY; + } + else { + return TCL_ERROR; + } + } + } + else { + return TCL_ERROR; + } + } + if (flags) { + *flags |= retValue; + } + return TCL_OK; +} + +/* +* WidgetFlagsHideGet -- +* Return 1 if option is hidden and 0 otherwise. +* +* Results: +* Return 1 if option is hidden and 0 otherwise. +* +* Side effects: +*/ +static int WidgetFlagsHideGet(Tcl_Obj *flags) +{ + const char *ch; + + ch = Tcl_GetString(flags); + if (ch[0] == 'h' || (ch[0] == 'r' && ch[1] == 'h')) { + return 1; + } + return 0; +} + +/* +* WidgetFlagsHideSet -- +* Set hidden option state. +* +* Results: +* Return object with new state. +* +* Side effects: +*/ +static Tcl_Obj *WidgetFlagsHideSet( + Tcl_Obj *flags) /* last flag value object */ +{ + const char *ch; + TkoThreadData *tkoPtr = (TkoThreadData *)Tcl_GetThreadData(&tkoKey, sizeof(TkoThreadData)); + + ch = Tcl_GetString(flags); + if (ch[0] != '\0' && (ch[0] == 'r' || ch[1] == 'r')) { + return tkoPtr->Obj_flags_rh; + } + return tkoPtr->Obj_flags_h; +} + +/* +* WidgetFlagsHideUnset -- +* Unset hidden option state. +* +* Results: +* Return object with new state. +* +* Side effects: +*/ +static Tcl_Obj *WidgetFlagsHideUnset( + Tcl_Obj *flags) /* last flag value object */ +{ + const char *ch; + TkoThreadData *tkoPtr = (TkoThreadData *)Tcl_GetThreadData(&tkoKey, sizeof(TkoThreadData)); + + ch = Tcl_GetString(flags); + if (ch[0] != '\0') { + if (ch[0] == 'h') { + if (ch[1] == 'r') { + return tkoPtr->Obj_flags_r; + } + else { + return tkoPtr->Obj_empty; + } + } + else { + if (ch[1] == 'h') { + return tkoPtr->Obj_flags_r; + } + } + } + return tkoPtr->Obj_empty; +} + +/* +* WidgetClientdataDelete -- +* Delete widget internal method clientdata. +* +* Results: +* None. +* +* Side effects: +* Free memory. +*/ +static void WidgetClientdataDelete( + ClientData clientdata) +{ + WidgetClientdata *cd = (WidgetClientdata *)clientdata; + Tcl_DecrRefCount(cd->option); + ckfree(cd); +} + +/* +* WidgetClientdataClone -- +* Copy widget internal method clientdata. +* +* Results: +* Return copied clientdata in newPtr. +* +* Side effects: +*/ +static int WidgetClientdataClone( + Tcl_Interp *dummy, + ClientData clientdata, + ClientData *newPtr) +{ + WidgetClientdata *cd = (WidgetClientdata *)clientdata; + (void)dummy; + + if (cd) { + *newPtr = ckalloc(sizeof(WidgetClientdata)); + assert(*newPtr); + memcpy(*newPtr, cd, sizeof(WidgetClientdata)); + Tcl_IncrRefCount(cd->option); + } + return TCL_OK; +} + +/* vim: set ts=4 sw=4 sts=4 ff=unix et : */ ADDED generic/tko/tkoWidget.h Index: generic/tko/tkoWidget.h ================================================================== --- /dev/null +++ generic/tko/tkoWidget.h @@ -0,0 +1,170 @@ +/* + * tkoWidget.h -- + * + * Header file for the internals of the tko widget package. + * + * Copyright (c) 2019 Rene Zaumseil + * + */ + +#ifndef _TKOWIDGET_H +#define _TKOWIDGET_H + +#include "tcl.h" +#include "tclInt.h" +#include "tclOO.h" +#include "tk.h" +#include "default.h" + +#ifndef _WIN32 +#if !defined(MAC_OSX_TK) +#include +#endif +#endif + +#if defined(_WIN32) +#include "tkWinInt.h" +#elif defined(MAC_OSX_TK) +#include "tkMacOSXInt.h" +#else +#include "tkUnixInt.h" +#endif + +/* + * For C++ compilers, use extern "C" + */ +#ifdef __cplusplus +extern "C" { +#endif + +/* + * Tko_WidgetOptionType -- + * + * Supported type in the TkoWidgetOptionSet() function. + * In comments is the type of the address pointer. + */ + typedef enum Tko_WidgetOptionType { + TKO_SET_NONE = 0, /* Nono */ + TKO_SET_CLASS = 1, /* (Tcl_Obj **)address */ + TKO_SET_VISUAL, /* (Tcl_Obj **)address */ + TKO_SET_COLORMAP, /* (Tcl_Obj **)address */ + TKO_SET_USE, /* (Tcl_Obj **)address */ + TKO_SET_CONTAINER, /* (int *)address */ + TKO_SET_TCLOBJ, /* (Tcl_Obj **)address */ + TKO_SET_XCOLOR, /* (Xcolor **)address */ + TKO_SET_3DBORDER, /* (Tk_3DBorder *)address */ + TKO_SET_PIXEL, /* (int *)address */ + TKO_SET_PIXELNONEGATIV, /* (int *)address */ + TKO_SET_PIXELPOSITIV, /* (int *)address */ + TKO_SET_DOUBLE, /* (double *)address */ + TKO_SET_BOOLEAN, /* (int *)address */ + TKO_SET_CURSOR, /* (Tk_Cursor *)address */ + TKO_SET_INT, /* (int *)address */ + TKO_SET_RELIEF, /* (int *)address */ + TKO_SET_ANCHOR, /* (int *)address */ + TKO_SET_WINDOW, /* (Tk_Window *)address */ + TKO_SET_FONT, /* (Tk_Font *)address */ + TKO_SET_STRING, /* (char **)address */ + TKO_SET_SCROLLREGION, /* (int *[4])address */ + TKO_SET_JUSTIFY /* (Tk_Justify *)address */ + } Tko_WidgetOptionType; + +/* +* Tko_CreateMode -- +* +* Supported values in Tko_WdigetCreate() function call. +*/ + typedef enum Tko_WidgetCreateMode { + TKO_CREATE_WIDGET, /* Create new widget */ + TKO_CREATE_TOPLEVEL, /* Create new toplevel widget */ + TKO_CREATE_CLASS, /* See "tko initclass" */ + TKO_CREATE_WRAP /* See "tko initwrap" */ + } Tko_WidgetCreateMode; + +/* + * Tko_WidgetOptionDefine -- + * + * Widget definition data used in class. + * An option set method "-option" is created in the following order: + * - "option"=NULL indicate the end of a list of option definitions. + * - If "method" is given it will be used as option set method. + * - If "type" is greater 0 a common option set method will be used. + * In this case "offset" are used as offset in the widget structure. + */ + typedef struct Tko_WidgetOptionDefine { + const char *option; /* Name of option. Starts with "-" minus sign */ + const char *dbname; /* Option DB name or synonym option if dbclass is NULL */ + const char *dbclass; /* Option DB class name or NULL for synonym options. */ + const char *defvalue; /* Default value. */ + int flags; /* bit array of TKO_OPTION_* values to configure option behaviour */ + Tcl_MethodCallProc *method; /* If not NULL it is the function name of the -option method */ + Tko_WidgetOptionType type; /* if greater 0 then option type used in common option set method */ + size_t offset; /* offset in meta data struct */ + } Tko_WidgetOptionDefine; +#define TKO_OPTION_READONLY 0x1 /* option is only setable at creation time */ +#define TKO_OPTION_HIDE 0x2 /* option is hidden in configure method */ +#define TKO_OPTION_NULL 0x4 /* empty values are saved as NULL */ +#define TKO_OPTION__USER 0x8 /* internally used */ + + /* + * Widget structure data used in objects. + * These structure will be filled in the **Tko\_WidgetCreate** call + * and cleared in the **Tko\_WidgetDestroy** call. + * Widget methods should check the value of *tkWin* on NULL before using it. + */ + typedef struct Tko_Widget { + Tk_Window tkWin; /* Window that embodies the widget. NULL means + * that the window has been destroyed but the + * data structures haven't yet been cleaned + * up.*/ + Display *display; /* Display containing widget. Used, among + * other things, so that resources can be + * freed even after tkwin has gone away. */ + Tcl_Interp *interp; /* Interpreter associated with widget. */ + Tcl_Command widgetCmd; /* Token for command. */ + Tcl_Object object; /* our own object */ + Tcl_Obj *myCmd; /* Objects "my" command. Needed to call internal methods. */ + Tcl_Obj *optionsArray; /* Name of option array variable */ + Tcl_HashTable *optionsTable; /* Hash table containing all used options */ + } Tko_Widget; + +/* tkoFrame.c */ + MODULE_SCOPE int Tko_FrameInit( + Tcl_Interp * interp); + MODULE_SCOPE int Tko_VectorInit( + Tcl_Interp * interp); + MODULE_SCOPE int Tko_GraphInit( + Tcl_Interp * interp); +/* tkoWidget.c */ + MODULE_SCOPE int Tko_WidgetClassDefine( + Tcl_Interp *interp, + Tcl_Obj *classname, + const Tcl_MethodType *methods, + const Tko_WidgetOptionDefine *options); + MODULE_SCOPE int Tko_WidgetCreate( + ClientData clientdata, + Tcl_Interp *interp, + Tcl_Object object, + Tko_WidgetCreateMode createmode, + Tcl_Obj *arglist); + MODULE_SCOPE void Tko_WidgetDestroy( + Tcl_ObjectContext context); + MODULE_SCOPE ClientData Tko_WidgetClientData( + Tcl_ObjectContext context); + MODULE_SCOPE Tcl_Obj *Tko_WidgetOptionGet( + Tko_Widget *widget, + Tcl_Obj *option); + MODULE_SCOPE Tcl_Obj *Tko_WidgetOptionSet( + Tko_Widget *widget, + Tcl_Obj *option, + Tcl_Obj *value); + +/* + * end block for C++ + */ + +#ifdef __cplusplus +} +#endif +#endif /* _TKOWIDGET_H */ +/* vim: set ts=4 sw=4 sts=4 ff=unix et : */ ADDED tests/tko/all.tcl Index: tests/tko/all.tcl ================================================================== --- /dev/null +++ tests/tko/all.tcl @@ -0,0 +1,17 @@ +# all.tcl -- +# +# This file contains a top-level script to run all of the Tcl +# tests. Execute it by invoking "make test" +# + +# restart using tclsh \ +exec tclsh "$0" "$@" + +package require Tk ;# This is for a Tk Widget; fail early if no Tk! +package require tcltest 2 + +tcltest::configure {*}$argv +tcltest::configure -testdir [file normalize [file dirname [info script]]] +tcltest::configure -singleproc 1 +tcltest::runAllTests + ADDED tests/tko/tkoFrame.test Index: tests/tko/tkoFrame.test ================================================================== --- /dev/null +++ tests/tko/tkoFrame.test @@ -0,0 +1,2213 @@ +# This file is a Tcl script to test out the "frame" and "toplevel" +# commands of Tko. It is organized in the standard fashion for Tcl +# tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1996 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. + +package require tcltest +namespace import ::tcltest::* +namespace eval ::TEST { + +proc ::TEST::deleteWindows {} { + destroy {*}[winfo children .] +} + +# ::TEST::eatColors -- +# Creates a toplevel window and allocates enough colors in it to +# use up all the slots in the colormap. +# +# Arguments: +# w - Name of toplevel window to create. + +proc ::TEST::eatColors {w} { + catch {destroy $w} + ::tko::toplevel $w + wm geom $w +0+0 + canvas $w.c -width 400 -height 200 -bd 0 + pack $w.c + for {set y 0} {$y < 8} {incr y} { + for {set x 0} {$x < 40} {incr x} { + set color [format #%02x%02x%02x [expr $x*6] [expr $y*30] 0] + $w.c create rectangle [expr 10*$x] [expr 20*$y] \ + [expr 10*$x + 10] [expr 20*$y + 20] -outline {} \ + -fill $color + } + } + update +} + +# ::TEST::colorsFree -- +# +# Returns 1 if there appear to be free colormap entries in a window, +# 0 otherwise. +# +# Arguments: +# w - Name of window in which to check. +# red, green, blue - Intensities to use in a trial color allocation +# to see if there are colormap entries free. + +proc ::TEST::colorsFree {w {red 31} {green 245} {blue 192}} { + set vals [winfo rgb $w [format #%02x%02x%02x $red $green $blue]] + expr ([lindex $vals 0]/256 == $red) && ([lindex $vals 1]/256 == $green) \ + && ([lindex $vals 2]/256 == $blue) +} + +# +# Test ::tko::frame configuration options +# +test frame-1.1 {frame configuration options} -setup { + deleteWindows +} -body { + ::tko::frame .f -class NewFrame + .f configure -class +} -cleanup { + deleteWindows +} -result {-class class Class TkoFrame NewFrame} + +test frame-1.2 {frame configuration options} -setup { + deleteWindows +} -body { + ::tko::frame .f -class NewFrame + .f configure -class Different +} -cleanup { + deleteWindows +} -returnCodes error -match glob -result {*: option "-class" is readonly} + +test frame-1.3 {frame configuration options} -setup { + deleteWindows +} -body { + ::tko::frame .f -colormap new + .f configure -colormap +} -cleanup { + deleteWindows +} -result {-colormap colormap Colormap {} new} + +test frame-1.4 {frame configuration options} -setup { + deleteWindows +} -body { + ::tko::frame .f -colormap new + .f configure -colormap . +} -cleanup { + deleteWindows +} -returnCodes error -match glob -result {*: option "-colormap" is readonly} + +test frame-1.5 {frame configuration options} -setup { + deleteWindows +} -body { + ::tko::frame .f -visual default + .f configure -visual +} -cleanup { + deleteWindows +} -result {-visual visual Visual {} default} + +test frame-1.6 {frame configuration options} -setup { + deleteWindows +} -body { + ::tko::frame .f -visual default + .f configure -visual best +} -cleanup { + deleteWindows +} -returnCodes error -match glob -result {*: option "-visual" is readonly} + +test frame-1.7 {frame configuration options} -setup { + deleteWindows +} -body { + ::tko::frame .f -screen bogus +} -cleanup { + deleteWindows +} -returnCodes error -match glob -result {unknown options: -screen bogus} + +test frame-1.8 {frame configuration options} -setup { + deleteWindows +} -body { + ::tko::frame .f -container true +} -cleanup { + deleteWindows +} -result {.f} + +test frame-1.9 {frame configuration options} -setup { + deleteWindows +} -body { + ::tko::frame .f -container true + .f configure -container +} -cleanup { + deleteWindows +} -result {-container container Container 0 1} + +test frame-1.10 {frame configuration options} -setup { + deleteWindows +} -body { + ::tko::frame .f -container bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {expected boolean value but got "bogus"} + +test frame-1.11 {frame configuration options} -setup { + deleteWindows +} -body { + ::tko::frame .f + .f configure -container 1 +} -cleanup { + deleteWindows +} -returnCodes error -match glob -result {*: option "-container" is readonly} + +test frame-1.12 {frame configuration options} -setup { + deleteWindows +} -body { + # Make sure all options can be set to the default value + ::tko::frame .f + set opts {} + foreach opt [.f configure] { + if {[llength $opt] == 5} { + lappend opts [lindex $opt 0] [lindex $opt 4] + } + } + eval ::tko::frame .g $opts + destroy .f .g +} -cleanup { + deleteWindows +} -result {} + +destroy .f +::tko::frame .f +test frame-1.13 {frame configuration options} -body { + .f configure -background #ff0000 + lindex [.f configure -background] 4 +} -cleanup { + .f configure -background [lindex [.f configure -background] 3] +} -result {#ff0000} + +test frame-1.14 {frame configuration options} -body { + .f configure -background non-existent +} -returnCodes error -match glob -result {*: unknown color name "non-existent"} + +test frame-1.15 {frame configuration options} -body { + .f configure -bd 4 + lindex [.f configure -bd] 4 +} -cleanup { + .f configure -bd [lindex [.f configure -bd] 3] +} -result {4} + +test frame-1.16 {frame configuration options} -body { + .f configure -bd badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} + +test frame-1.17 {frame configuration options} -body { + .f configure -bg #00ff00 + lindex [.f configure -bg] 4 +} -cleanup { + .f configure -bg [lindex [.f configure -bg] 3] +} -result {#00ff00} + +test frame-1.18 {frame configuration options} -body { + .f configure -bg non-existent +} -returnCodes error -match glob -result {*: unknown color name "non-existent"} + +test frame-1.19 {frame configuration options} -body { + .f configure -borderwidth 1.3 + lindex [.f configure -borderwidth] 4 +} -cleanup { + .f configure -borderwidth [lindex [.f configure -borderwidth] 3] +} -result {1} + +test frame-1.20 {frame configuration options} -body { + .f configure -borderwidth badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} + +test frame-1.21 {frame configuration options} -body { + .f configure -cursor arrow + lindex [.f configure -cursor] 4 +} -cleanup { + .f configure -cursor [lindex [.f configure -cursor] 3] +} -result {arrow} + +test frame-1.22 {frame configuration options} -body { + .f configure -cursor badValue +} -returnCodes error -match glob -result {*: bad cursor spec "badValue"} + +test frame-1.23 {frame configuration options} -body { + .f configure -height 100 + lindex [.f configure -height] 4 +} -cleanup { + .f configure -height [lindex [.f configure -height] 3] +} -result {100} + +test frame-1.24 {frame configuration options} -body { + .f configure -height not_a_number +} -returnCodes error -match glob -result {*: bad screen distance "not_a_number"} + +test frame-1.25 {frame configuration options} -body { + .f configure -highlightbackground #112233 + lindex [.f configure -highlightbackground] 4 +} -cleanup { + .f configure -highlightbackground [lindex [.f configure -highlightbackground] 3] +} -result {#112233} + +test frame-1.26 {frame configuration options} -body { + .f configure -highlightbackground ugly +} -returnCodes error -match glob -result {*: unknown color name "ugly"} + +test frame-1.27 {frame configuration options} -body { + .f configure -highlightcolor #123456 + lindex [.f configure -highlightcolor] 4 +} -cleanup { + .f configure -highlightcolor [lindex [.f configure -highlightcolor] 3] +} -result {#123456} + +test frame-1.28 {frame configuration options} -body { + .f configure -highlightcolor non-existent +} -returnCodes error -match glob -result {*: unknown color name "non-existent"} + +test frame-1.29 {frame configuration options} -body { + .f configure -highlightthickness 6 + lindex [.f configure -highlightthickness] 4 +} -cleanup { + .f configure -highlightthickness [lindex [.f configure -highlightthickness] 3] +} -result {6} + +test frame-1.30 {frame configuration options} -body { + .f configure -highlightthickness badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} + +test frame-1.31 {frame configuration options} -body { + .f configure -padx 3 + lindex [.f configure -padx] 4 +} -cleanup { + .f configure -padx [lindex [.f configure -padx] 3] +} -result {3} + +test frame-1.32 {frame configuration options} -body { + .f configure -padx badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} + +test frame-1.33 {frame configuration options} -body { + .f configure -pady 4 + lindex [.f configure -pady] 4 +} -cleanup { + .f configure -pady [lindex [.f configure -pady] 3] +} -result {4} + +test frame-1.34 {frame configuration options} -body { + .f configure -pady badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} + +test frame-1.35 {frame configuration options} -body { + .f configure -relief ridge + lindex [.f configure -relief] 4 +} -cleanup { + .f configure -relief [lindex [.f configure -relief] 3] +} -result {ridge} + +test frame-1.36 {frame configuration options} -body { + .f configure -relief badValue +} -returnCodes error -match glob -result {*: bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} + +test frame-1.37 {frame configuration options} -body { + .f configure -takefocus {any string} + lindex [.f configure -takefocus] 4 +} -cleanup { + .f configure -takefocus [lindex [.f configure -takefocus] 3] +} -result {any string} + +test frame-1.38 {frame configuration options} -body { + .f configure -width 32 + lindex [.f configure -width] 4 +} -cleanup { + .f configure -width [lindex [.f configure -width] 3] +} -result {32} + +test frame-1.39 {frame configuration options} -body { + .f configure -width badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} +destroy .f + +# +# Test ::tko::toplevel configuration options +# + +test frame-2.1 {toplevel configuration options} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 200 -height 100 -class NewClass + wm geometry .t +0+0 + .t configure -class +} -cleanup { + deleteWindows +} -result {-class class Class TkoToplevel NewClass} + +test frame-2.2 {toplevel configuration options} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 200 -height 100 -class NewClass + wm geometry .t +0+0 + .t configure -class Another +} -cleanup { + deleteWindows +} -returnCodes error -match glob -result {*: option "-class" is readonly} + +test frame-2.3 {toplevel configuration options} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 200 -height 100 -colormap new + wm geometry .t +0+0 + .t configure -colormap +} -cleanup { + deleteWindows +} -result {-colormap colormap Colormap {} new} + +test frame-2.4 {toplevel configuration options} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 200 -height 100 -colormap new + wm geometry .t +0+0 + .t configure -colormap . +} -cleanup { + deleteWindows +} -returnCodes error -match glob -result {*: option "-colormap" is readonly} + +test frame-2.5 {toplevel configuration options} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 200 -height 100 + wm geometry .t +0+0 + .t configure -container 1 +} -cleanup { + deleteWindows +} -returnCodes error -match glob -result {*: option "-container" is readonly} + +test frame-2.6 {toplevel configuration options} -setup { + deleteWindows +} -body { + catch {destroy .t} + ::tko::toplevel .t -width 200 -height 100 + wm geometry .t +0+0 + catch {.t configure -container 1} + .t configure -container +} -cleanup { + deleteWindows +} -result {-container container Container 0 0} + +test frame-2.7 {toplevel configuration options} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 200 -height 100 -colormap bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {bad window path name "bogus"} + +test frame-2.8 {toplevel configuration options} -constraints { + win +} -setup { + deleteWindows +} -body { + catch {destroy .t} + ::tko::toplevel .t -width 200 -height 100 -use 0x44022 +# wm geometry .t +0+0 +# .t configure -use 0x44022 +} -cleanup { + deleteWindows +} -returnCodes error -result {window "0x44022" doesn't exist} + +test frame-2.9 {toplevel configuration options} -constraints { + win +} -setup { + deleteWindows +} -body { + catch {destroy .t} + ::tko::toplevel .t -width 200 -height 100 + wm geometry .t +0+0 + catch {.t configure -use 0x44022} + .t configure -use +} -cleanup { + deleteWindows +} -result {-use use Use {} {}} + +test frame-2.10 {toplevel configuration options} -constraints { + nonwin +} -setup { + deleteWindows +} -body { + catch {destroy .t} + ::tko::toplevel .t -width 200 -height 100 + wm geometry .t +0+0 + .t configure -use 0x44022 +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -use option after widget is created} + +test frame-2.11 {toplevel configuration options} -constraints { + nonwin +} -setup { + deleteWindows +} -body { + catch {destroy .t} + ::tko::toplevel .t -width 200 -height 100 + wm geometry .t +0+0 + catch {.t configure -use 0x44022} + .t configure -use +} -cleanup { + deleteWindows +} -result {-use use Use {} {}} + +test frame-2.12 {toplevel configuration options} -setup { + deleteWindows +} -body { + catch {destroy .t} + ::tko::toplevel .t -width 200 -height 100 -visual default + wm geometry .t +0+0 + .t configure -visual +} -cleanup { + deleteWindows +} -result {-visual visual Visual {} default} + +test frame-2.13 {toplevel configuration options} -setup { + deleteWindows +} -body { + catch {destroy .t} + ::tko::toplevel .t -width 200 -height 100 -visual default + wm geometry .t +0+0 + .t configure -visual best +} -cleanup { + deleteWindows +} -returnCodes error -match glob -result {*: option "-visual" is readonly} + +test frame-2.14 {toplevel configuration options} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 200 -height 100 -visual who_knows? +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown or ambiguous visual name "who_knows?": class must be best, directcolor, grayscale, greyscale, pseudocolor, staticcolor, staticgray, staticgrey, truecolor, or default} + +test frame-2.15 {toplevel configuration options} -constraints haveDISPLAY -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 200 -height 100 -screen $env(DISPLAY) + wm geometry .t +0+0 + string compare [.t configure -screen] "-screen screen Screen {} $env(DISPLAY)" +} -cleanup { + deleteWindows +} -result {0} + +test frame-2.16 {toplevel configuration options} -constraints haveDISPLAY -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 200 -height 100 -screen $env(DISPLAY) + wm geometry .t +0+0 + .t configure -screen another +} -cleanup { + deleteWindows +} -returnCodes error -result {can't modify -screen option after widget is created} + +test frame-2.17 {toplevel configuration options} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 200 -height 100 -screen bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {couldn't connect to display "bogus"} + + +test frame-2.18 {toplevel configuration options} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -container 1 -width 300 -height 120 + wm geometry .t +0+0 + ::tko::toplevel .x -container 1 -use [winfo id .t] +} -cleanup { + deleteWindows +} -returnCodes error -result {windows cannot have both the -use and the -container option set} + +test frame-2.19 {toplevel configuration options} -setup { + deleteWindows + set opts {} +} -body { + # Make sure all options can be set to the default value + ::tko::toplevel .f + foreach opt [.f configure] { + if {[llength $opt] == 5} { + lappend opts [lindex $opt 0] [lindex $opt 4] + } + } + eval ::tko::toplevel .g $opts + destroy .f .g +} -cleanup { + deleteWindows +} -result {} + +destroy .t +::tko::toplevel .t -width 300 -height 150 +wm geometry .t +0+0 +update +test frame-2.20 {toplevel configuration options} -body { + .t configure -background #ff0000 + lindex [.t configure -background] 4 +} -result {#ff0000} + +test frame-2.21 {toplevel configuration options} -body { + .t configure -background non-existent +} -returnCodes error -match glob -result {*: unknown color name "non-existent"} + +test frame-2.22 {toplevel configuration options} -body { + .t configure -bd 4 + lindex [.t configure -bd] 4 +} -result {4} + +test frame-2.23 {toplevel configuration options} -body { + .t configure -bd badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} + +test frame-2.24 {toplevel configuration options} -body { + .t configure -bg #00ff00 + lindex [.t configure -bg] 4 +} -result {#00ff00} + +test frame-2.25 {toplevel configuration options} -body { + .t configure -bg non-existent +} -returnCodes error -match glob -result {*: unknown color name "non-existent"} + +test frame-2.26 {toplevel configuration options} -body { + .t configure -borderwidth 1.3 + lindex [.t configure -borderwidth] 4 +} -result {1} + +test frame-2.27 {toplevel configuration options} -body { + .t configure -borderwidth badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} + +test frame-2.28 {toplevel configuration options} -body { + .t configure -cursor arrow + lindex [.t configure -cursor] 4 +} -result {arrow} + +test frame-2.29 {toplevel configuration options} -body { + .t configure -cursor badValue +} -returnCodes error -match glob -result {*: bad cursor spec "badValue"} + +test frame-2.30 {toplevel configuration options} -body { + .t configure -height 100 + lindex [.t configure -height] 4 +} -result {100} + +test frame-2.31 {toplevel configuration options} -body { + .t configure -height not_a_number +} -returnCodes error -match glob -result {*: bad screen distance "not_a_number"} + +test frame-2.32 {toplevel configuration options} -body { + .t configure -highlightcolor #123456 + lindex [.t configure -highlightcolor] 4 +} -result {#123456} + +test frame-2.33 {toplevel configuration options} -body { + .t configure -highlightcolor non-existent +} -returnCodes error -match glob -result {*: unknown color name "non-existent"} + +test frame-2.34 {toplevel configuration options} -body { + .t configure -highlightthickness 3 + lindex [.t configure -highlightthickness] 4 +} -result {3} + +test frame-2.35 {toplevel configuration options} -body { + .t configure -highlightthickness badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} + +test frame-2.36 {toplevel configuration options} -body { + .t configure -padx 3 + lindex [.t configure -padx] 4 +} -result {3} + +test frame-2.37 {toplevel configuration options} -body { + .t configure -padx badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} + +test frame-2.38 {toplevel configuration options} -body { + .t configure -pady 4 + lindex [.t configure -pady] 4 +} -result {4} + +test frame-2.39 {toplevel configuration options} -body { + .t configure -pady badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} + +test frame-2.40 {toplevel configuration options} -body { + .t configure -relief ridge + lindex [.t configure -relief] 4 +} -result {ridge} + +test frame-2.41 {toplevel configuration options} -body { + .t configure -relief badValue +} -returnCodes error -match glob -result {*: bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} + +test frame-2.42 {toplevel configuration options} -body { + .t configure -width 32 + lindex [.t configure -width] 4 +} -result {32} + +test frame-2.43 {toplevel configuration options} -body { + .t configure -width badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} +destroy .t + +# +# Test ::tko::labelframe configuration options +# +test frame-3.1 {TkCreateFrame procedure} -body { + ::tko::frame +} -returnCodes error -result {wrong # args: should be "::tko::frame pathName ?arg ...?"} + +test frame-3.2 {TkCreateFrame procedure} -setup { + deleteWindows + ::tko::frame .f +} -body { + .f configure -class +} -cleanup { + deleteWindows +} -result {-class class Class TkoFrame TkoFrame} + +test frame-3.3 {TkCreateFrame procedure} -setup { + deleteWindows + ::tko::toplevel .t + wm geometry .t +0+0 +} -body { + .t configure -class +} -cleanup { + deleteWindows +} -result {-class class Class TkoToplevel TkoToplevel} + +test frame-3.4 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 350 -class NewClass -bg black -visual default -height 90 + wm geometry .t +0+0 + update + list [lindex [.t configure -width] 4] \ + [lindex [.t configure -background] 4] \ + [lindex [.t configure -height] 4] +} -cleanup { + deleteWindows +} -result {350 black 90} + +# Be sure that the -class, -colormap, and -visual options are processed +# before configuring the widget. + +test frame-3.5 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { + option add *NewFrame.background #123456 + ::tko::frame .f -class NewFrame + lindex [.f configure -background] 4 +} -cleanup { + deleteWindows + option clear +} -result {#123456} + +test frame-3.6 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { + option add *NewFrame.background #123456 + ::tko::frame .f -class NewFrame + lindex [.f configure -background] 4 +} -cleanup { + deleteWindows + option clear +} -result {#123456} + +test frame-3.7 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { + option add *NewFrame.background #332211 + option add *f.class NewFrame + ::tko::frame .f + list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4] +} -cleanup { + deleteWindows + option clear +} -result {NewFrame #332211} + +test frame-3.8 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { + option add *Silly.background #122334 + option add *f.Class Silly + ::tko::frame .f + list [lindex [.f configure -class] 4] [lindex [.f configure -background] 4] +} -cleanup { + deleteWindows + option clear +} -result {Silly #122334} + +test frame-3.9 {TkCreateFrame procedure, -use option} -constraints { + unix +} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -container 1 -width 300 -height 120 + wm geometry .t +0+0 + ::tko::toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green + tkwait visibility .x + list [expr {[winfo rootx .x] - [winfo rootx .t]}] \ + [expr {[winfo rooty .x] - [winfo rooty .t]}] \ + [winfo width .t] [winfo height .t] +} -cleanup { + # This call to update idletasks was added to prevent a crash that was + # observed on OSX 10.12 (Sierra) only. Any change, such as using the + # Development version to make debugging symbols available, adding a print + # statement, or calling update idletasks here, would make the test pass + # with no segfault. + update idletasks + deleteWindows +} -result {0 0 140 300} + +test frame-3.10 {TkCreateFrame procedure, -use option} -constraints { + unix +} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -container 1 -width 300 -height 120 + wm geometry .t +0+0 + option add *x.use [winfo id .t] + ::tko::toplevel .x -width 140 -height 300 -bg green + tkwait visibility .x + list [expr {[winfo rootx .x] - [winfo rootx .t]}] \ + [expr {[winfo rooty .x] - [winfo rooty .t]}] \ + [winfo width .t] [winfo height .t] +} -cleanup { + destroy .t + option clear +} -result {0 0 140 300} + +# The tests below require specific display characteristics (i.e. that +# they are run on a pseudocolor display of depth 8). Even so, they +# are non-portable: some machines don't seem to ever run out of +# colors. +if {[testConstraint defaultPseudocolor8]} { + ::TEST::eatColors .t1 +} +test frame-3.11 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 300 -height 200 -bg #475601 + wm geometry .t +0+0 + update + ::TEST::colorsFree .t +} -cleanup { + deleteWindows +} -result {0} + +test frame-3.12 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 300 -height 200 -bg #475601 -colormap new + wm geometry .t +0+0 + update + ::TEST::colorsFree .t +} -cleanup { + deleteWindows +} -result {1} + +test frame-3.13 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { + option add *t.class Toplevel2 + option add *Toplevel2.colormap new + ::tko::toplevel .t -width 300 -height 200 -bg #475601 + wm geometry .t +0+0 + update + option clear + ::TEST::colorsFree .t +} -cleanup { + deleteWindows +} -result {1} + +test frame-3.14 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { + option add *t.class Toplevel3 + option add *Toplevel3.Colormap new + ::tko::toplevel .t -width 300 -height 200 -bg #475601 -colormap new + wm geometry .t +0+0 + update + option clear + ::TEST::colorsFree .t +} -cleanup { + deleteWindows +} -result {1} + +test frame-3.15 {TkCreateFrame procedure, -use and -colormap} -constraints { + defaultPseudocolor8 unix nonPortable +} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -container 1 -width 300 -height 120 + wm geometry .t +0+0 + ::tko::toplevel .x -width 140 -height 300 -use [winfo id .t] -bg green -colormap new + tkwait visibility .x + list [::TEST::colorsFree .t] [::TEST::colorsFree .x] +} -cleanup { + destroy .t +} -result {0 1} + +test frame-3.16 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 300 -height 200 -bg #475601 -visual default + wm geometry .t +0+0 + update + ::TEST::colorsFree .t +} -cleanup { + deleteWindows +} -result {0} + +test frame-3.17 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 nonPortable +} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 300 -height 200 -bg #475601 -visual default \ + -colormap new + wm geometry .t +0+0 + update + ::TEST::colorsFree .t +} -cleanup { + deleteWindows +} -result {1} + +test frame-3.18 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 haveGrayscale8 nonPortable +} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 + wm geometry .t +0+0 + update + ::TEST::colorsFree .t 131 131 131 +} -cleanup { + deleteWindows +} -result {1} + +test frame-3.19 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 haveGrayscale8 nonPortable +} -setup { + deleteWindows +} -body { + option add *t.class T4 + option add *T4.visual {grayscale 8} + ::tko::toplevel .t -width 300 -height 200 -bg #434343 + wm geometry .t +0+0 + update + option clear + list [::TEST::colorsFree .t 131 131 131] [lindex [.t configure -visual] 4] +} -cleanup { + deleteWindows +} -result {1 {grayscale 8}} + +test frame-3.20 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 haveGrayscale8 nonPortable +} -setup { + deleteWindows +} -body { + set x ok + option add *t.class T5 + option add *T5.Visual {grayscale 8} + ::tko::toplevel .t -width 300 -height 200 -bg #434343 + wm geometry .t +0+0 + update + option clear + list [::TEST::colorsFree .t 131 131 131] [lindex [.t configure -visual] 4] +} -cleanup { + deleteWindows +} -result {1 {grayscale 8}} + +test frame-3.21 {TkCreateFrame procedure} -constraints { + defaultPseudocolor8 haveGrayscale8 nonPortable +} -setup { + deleteWindows +} -body { + set x ok + ::tko::toplevel .t -visual {grayscale 8} -width 300 -height 200 -bg #434343 + wm geometry .t +0+0 + update + ::TEST::colorsFree .t 131 131 131 +} -cleanup { + deleteWindows +} -result {1} +if {[testConstraint defaultPseudocolor8]} { + destroy .t1 +} + +test frame-3.22 {TkCreateFrame procedure, default dimensions} -setup { + deleteWindows +} -body { + ::tko::toplevel .t + wm geometry .t +0+0 + update + set result "[winfo reqwidth .t] [winfo reqheight .t]" + ::tko::frame .t.f -bg red + pack .t.f + update + lappend result [winfo reqwidth .t.f] [winfo reqheight .t.f] +} -cleanup { + deleteWindows +} -result {200 200 1 1} + +test frame-3.23 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { + ::tko::frame .f -gorp glob +} -returnCodes error -result {unknown options: -gorp glob} + +test frame-3.24 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 300 -height 200 -colormap new -bogus option + wm geometry .t +0+0 +} -returnCodes error -result {unknown options: -bogus option} + + +test frame-4.1 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { + catch {::tko::frame .f -gorp glob} + winfo exists .f +} -result 0 + +test frame-4.2 {TkCreateFrame procedure} -setup { + deleteWindows +} -body { + list [::tko::frame .f -width 200 -height 100] [winfo exists .f] +} -cleanup { + deleteWindows +} -result {.f 1} + + +::tko::frame .f -highlightcolor black + +test frame-5.1 {FrameWidgetCommand procedure} -body { + .f +} -returnCodes error -result {wrong # args: should be ".f method ?arg ...?"} + +test frame-5.2 {FrameWidgetCommand procedure, cget option} -body { + .f cget +} -returnCodes error -result {wrong # args: should be ".f cget option"} + +test frame-5.3 {FrameWidgetCommand procedure, cget option} -body { + .f cget a b +} -returnCodes error -result {wrong # args: should be ".f cget option"} + +test frame-5.4 {FrameWidgetCommand procedure, cget option} -body { + .f cget -gorp +} -returnCodes error -result {unknown option "-gorp"} + +test frame-5.5 {FrameWidgetCommand procedure, cget option} -body { + .f cget -highlightcolor +} -result {black} + +test frame-5.6 {FrameWidgetCommand procedure, cget option} -body { + .f cget -screen +} -returnCodes error -result {unknown option "-screen"} + +test frame-5.7 {FrameWidgetCommand procedure, cget option} -setup { + destroy .t +} -body { + ::tko::toplevel .t + .t cget -screen +} -cleanup { + destroy .t +} -returnCodes ok -match glob -result * + +test frame-5.8 {FrameWidgetCommand procedure, configure option} -body { + llength [.f configure] +} -result {21} + +test frame-5.9 {FrameWidgetCommand procedure, configure option} -body { + .f configure -gorp +} -returnCodes error -result {unknown option "-gorp"} + +test frame-5.10 {FrameWidgetCommand procedure, configure option} -body { + .f configure -gorp bogus +} -returnCodes error -result {unknown option "-gorp"} + +test frame-5.11 {FrameWidgetCommand procedure, configure option} -body { + .f configure -width 200 -height +} -returnCodes error -result {wrong # args: should be ".f configure ?-option value ..?"} + +test frame-5.12 {FrameWidgetCommand procedure} -body { + .f swizzle +} -returnCodes error -result {unknown method "swizzle": must be cget or configure} + +test frame-5.13 {FrameWidgetCommand procedure, configure option} -body { + llength [. configure] +} -result {24} +destroy .f + +test frame-6.1 {ConfigureFrame procedure} -setup { + deleteWindows +} -body { + ::tko::frame .f -width 150 + list [winfo reqwidth .f] [winfo reqheight .f] +} -cleanup { + deleteWindows +} -result {150 1} + +test frame-6.2 {ConfigureFrame procedure} -setup { + deleteWindows +} -body { + ::tko::frame .f -height 97 + list [winfo reqwidth .f] [winfo reqheight .f] +} -cleanup { + deleteWindows +} -result {1 97} + +test frame-6.3 {ConfigureFrame procedure} -setup { + deleteWindows +} -body { + ::tko::frame .f + set result {} + lappend result [winfo reqwidth .f] [winfo reqheight .f] + .f configure -width 100 -height 180 + lappend result [winfo reqwidth .f] [winfo reqheight .f] + .f configure -width 0 -height 0 + lappend result [winfo reqwidth .f] [winfo reqheight .f] +} -cleanup { + deleteWindows +} -result {1 1 100 180 100 180} + +test frame-7.1 {FrameEventProc procedure} -setup { + deleteWindows +} -body { + ::tko::frame .frame2 + set result [info commands .frame2] + destroy .frame2 + lappend result [info commands .frame2] +} -result {.frame2 {}} + +test frame-7.2 {FrameEventProc procedure} -setup { + deleteWindows + set x {} +} -body { + frame .f1 -bg #543210 + rename .f1 .f2 + lappend x [winfo children .] + lappend x [.f2 cget -bg] + destroy .f1 + lappend x [info command .f*] [winfo children .] +} -cleanup { + deleteWindows +} -result {.f1 #543210 {} {}} + +test frame-8.1 {FrameCmdDeletedProc procedure} -setup { + deleteWindows +} -body { + ::tko::frame .f1 + rename .f1 {} + list [info command .f*] [winfo children .] +} -cleanup { + deleteWindows +} -result {{} {}} + +test frame-8.2 {FrameCmdDeletedProc procedure} -setup { + deleteWindows +} -body { + ::tko::toplevel .f1 -menu .m + wm geometry .f1 +0+0 + update + rename .f1 {} + update + list [info command .f*] [winfo children .] +} -cleanup { + deleteWindows +} -result {{} {}} +# +# This one fails with the dash-patch!!!! Still don't know why :-( +# +#test frame-8.3 {FrameCmdDeletedProc procedure} -setup { +# eval destroy [winfo children .] +# deleteWindows +#} -body { +# ::tko::toplevel .f1 -menu .m +# wm geometry .f1 +0+0 +# menu .m +# update +# rename .f1 {} +# update +# list [info command .f*] [winfo children .] +#} -cleanup { +# eval destroy [winfo children .] +# deleteWindows +#} -result {{} .m} + +test frame-9.1 {MapFrame procedure} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 100 -height 400 + wm geometry .t +0+0 + set result [winfo ismapped .t] + update idletasks + lappend result [winfo ismapped .t] +} -cleanup { + deleteWindows +} -result {0 1} + +test frame-9.2 {MapFrame procedure} -setup { + deleteWindows +} -body { + ::tko::toplevel .t -width 100 -height 400 + wm geometry .t +0+0 + destroy .t + update + winfo exists .t +} -result {0} + +test frame-9.3 {MapFrame procedure, window deleted while mapping} -setup { + deleteWindows +} -body { + ::tko::toplevel .t2 -width 200 -height 200 + wm geometry .t2 +0+0 + tkwait visibility .t2 + ::tko::toplevel .t -width 100 -height 400 + wm geometry .t +0+0 + ::tko::frame .t2.f -width 50 -height 50 + bind .t2.f {destroy .t} + pack .t2.f -side top + update idletasks + winfo exists .t +} -cleanup { + deleteWindows +} -result {0} + + +test frame-10.1 {frame widget vs hidden commands} -setup { + deleteWindows +} -body { + set l [interp hidden] + ::tko::frame .t + interp hide {} .t + destroy .t + set res1 [list [winfo children .] [interp hidden]] + set res2 [list {} $l] + expr {$res1 eq $res2} +} -result 1 + + +test frame-11.1 {TkInstallFrameMenu} -setup { + deleteWindows +} -body { + menu .m1 + .m1 add cascade -menu .m1.system + menu .m1.system -tearoff 0 + .m1.system add command -label foo + ::tko::toplevel .t -menu .m1 +} -cleanup { +#TODO otherwise crash +destroy .t +destroy .m1 + deleteWindows +} -result {.t} + +test frame-11.2 {TkInstallFrameMenu - frame renamed} -setup { + deleteWindows +} -body { + catch {rename foo {}} + menu .m1 + .m1 add cascade -menu .m1.system + menu .m1.system -tearoff 0 + .m1.system add command -label foo + ::tko::toplevel .t + rename .t foo +} -cleanup { +#TODO otherwise crash +destroy .t +destroy .m1 + deleteWindows +} -result {} + + +test frame-12.1 {FrameWorldChanged procedure} -setup { + deleteWindows +} -body { + # Test -bd -padx and -pady + ::tko::frame .f -borderwidth 2 -padx 3 -pady 4 + place .f -x 0 -y 0 -width 40 -height 40 + pack [::tko::frame .f.f] -fill both -expand 1 + update + list [winfo x .f.f] [winfo y .f.f] [winfo width .f.f] [winfo height .f.f] +} -cleanup { + deleteWindows +} -result {5 6 30 28} + +test frame-12.2 {FrameWorldChanged procedure} -setup { + deleteWindows +} -body { + # Test all -labelanchor positions + set font {helvetica 12} + ::tko::labelframe .f -highlightthickness 1 -bd 3 -padx 1 -pady 2 -font $font \ + -text "Mupp" + set fh [expr {[font metrics $font -linespace] + 2 - 3}] + set fw [expr {[font measure $font "Mupp"] + 2 - 3}] + if {$fw < 0} {set fw 0} + if {$fh < 0} {set fh 0} + place .f -x 0 -y 0 -width 100 -height 100 + pack [::tko::frame .f.f] -fill both -expand 1 + + set result {} + foreach lp {nw n ne en e es se s sw ws w wn} { + .f configure -labelanchor $lp + update + set expx 5 + set expy 6 + set expw 90 + set exph 88 + switch -glob $lp { + n* {incr expy $fh ; incr exph -$fh} + s* {incr exph -$fh} + w* {incr expx $fw ; incr expw -$fw} + e* {incr expw -$fw} + } + lappend result [expr {\ + [winfo x .f.f] == $expx && [winfo y .f.f] == $expy &&\ + [winfo width .f.f] == $expw && [winfo height .f.f] == $exph}] + } + return $result +} -cleanup { + deleteWindows +} -result {1 1 1 1 1 1 1 1 1 1 1 1} + +test frame-12.3 {FrameWorldChanged procedure} -setup { + deleteWindows +} -body { + # Check reaction on font change + font create myfont -family courier -size 10 + ::tko::labelframe .f -font myfont -text Mupp + place .f -x 0 -y 0 -width 40 -height 40 + pack [::tko::frame .f.f] -fill both -expand 1 + update + set h1 [font metrics myfont -linespace] + set y1 [winfo y .f.f] + font configure myfont -size 20 + update + set h2 [font metrics myfont -linespace] + set y2 [winfo y .f.f] + expr {($h2 - $h1) - ($y2 - $y1)} +} -cleanup { + deleteWindows + font delete myfont +} -result {0} + + +test frame-13.1 {labelframe configuration options} -setup { + deleteWindows +} -body { + ::tko::labelframe .f -class NewFrame + .f configure -class +} -cleanup { + deleteWindows +} -result {-class class Class TkoLabelframe NewFrame} + +test frame-13.2 {labelframe configuration options} -setup { + deleteWindows +} -body { + ::tko::labelframe .f -class NewFrame + .f configure -class Different +} -cleanup { + deleteWindows +} -returnCodes error -match glob -result {*: option "-class" is readonly} + +test frame-13.3 {labelframe configuration options} -setup { + deleteWindows +} -body { + ::tko::labelframe .f -colormap new +} -cleanup { + deleteWindows +} -result {.f} + +test frame-13.4 {labelframe configuration options} -setup { + deleteWindows +} -body { + ::tko::labelframe .f -visual default +} -cleanup { + deleteWindows +} -result {.f} + +test frame-13.5 {labelframe configuration options} -setup { + deleteWindows +} -body { + ::tko::labelframe .f -screen bogus +} -cleanup { + deleteWindows +} -returnCodes error -result {unknown options: -screen bogus} + +test frame-13.6 {labelframe configuration options} -setup { + deleteWindows +} -body { + labelframe .f -container true +} -cleanup { + deleteWindows +} -result {.f} + +# Removed. Should be deprectaed in frame too. +#test frame-13.7 {labelframe configuration options} -setup { +# deleteWindows +#} -body { +# ::tko::labelframe .f -container true +# .f configure -container +#} -cleanup { +# deleteWindows +#} -result {-container container Container 0 1} +# +#test frame-13.8 {labelframe configuration options} -setup { +# deleteWindows +#} -body { +# ::tko::labelframe .f -container bogus +#} -cleanup { +# deleteWindows +#} -returnCodes error -result {expected boolean value but got "bogus"} +# +#test frame-13.9 {labelframe configuration options} -setup { +# deleteWindows +#} -body { +# ::tko::labelframe .f +# .f configure -container 1 +#} -cleanup { +# deleteWindows +#} -returnCodes error -result {can't modify -container option after widget is created} + +destroy .f +::tko::labelframe .f +test frame-13.10 {labelframe configuration options} -body { + .f configure -background #ff0000 + lindex [.f configure -background] 4 +} -cleanup { + .f configure -background [lindex [.f configure -background] 3] +} -result {#ff0000} + +test frame-13.11 {labelframe configuration options} -body { + .f configure -background non-existent +} -returnCodes error -match glob -result {*: unknown color name "non-existent"} + +test frame-13.12 {labelframe configuration options} -body { + .f configure -bd 4 + lindex [.f configure -bd] 4 +} -cleanup { + .f configure -bd [lindex [.f configure -bd] 3] +} -result {4} + +test frame-13.13 {labelframe configuration options} -body { + .f configure -bd badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} + +test frame-13.14 {labelframe configuration options} -body { + .f configure -bg #00ff00 + lindex [.f configure -bg] 4 +} -cleanup { + .f configure -bg [lindex [.f configure -bg] 3] +} -result {#00ff00} + +test frame-13.15 {labelframe configuration options} -body { + .f configure -bg non-existent +} -returnCodes error -match glob -result {*: unknown color name "non-existent"} + +test frame-13.16 {labelframe configuration options} -body { + .f configure -borderwidth 1.3 + lindex [.f configure -borderwidth] 4 +} -cleanup { + .f configure -borderwidth [lindex [.f configure -borderwidth] 3] +} -result {1} + +test frame-13.17 {labelframe configuration options} -body { + .f configure -borderwidth badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} + +test frame-13.18 {labelframe configuration options} -body { + .f configure -cursor arrow + lindex [.f configure -cursor] 4 +} -cleanup { + .f configure -cursor [lindex [.f configure -cursor] 3] +} -result {arrow} + +test frame-13.19 {labelframe configuration options} -body { + .f configure -cursor badValue +} -returnCodes error -match glob -result {*: bad cursor spec "badValue"} + +test frame-13.20 {labelframe configuration options} -body { + .f configure -fg #0000ff + lindex [.f configure -fg] 4 +} -cleanup { + .f configure -fg [lindex [.f configure -fg] 3] +} -result {#0000ff} + +test frame-13.21 {labelframe configuration options} -body { + .f configure -fg non-existent +} -returnCodes error -match glob -result {*: unknown color name "non-existent"} + +test frame-13.22 {labelframe configuration options} -body { + .f configure -font {courier 8} + lindex [.f configure -font] 4 +} -cleanup { + .f configure -font [lindex [.f configure -font] 3] +} -result {courier 8} + +test frame-13.23 {labelframe configuration options} -body { + .f configure -foreground #ff0000 + lindex [.f configure -foreground] 4 +} -cleanup { + .f configure -foreground [lindex [.f configure -foreground] 3] +} -result {#ff0000} + +test frame-13.24 {labelframe configuration options} -body { + .f configure -foreground non-existent +} -returnCodes error -match glob -result {*: unknown color name "non-existent"} + +test frame-13.25 {labelframe configuration options} -body { + .f configure -height 100 + lindex [.f configure -height] 4 +} -cleanup { + .f configure -height [lindex [.f configure -height] 3] +} -result {100} + +test frame-13.26 {labelframe configuration options} -body { + .f configure -height not_a_number +} -returnCodes error -match glob -result {*: bad screen distance "not_a_number"} + +test frame-13.27 {labelframe configuration options} -body { + .f configure -highlightbackground #112233 + lindex [.f configure -highlightbackground] 4 +} -cleanup { + .f configure -highlightbackground [lindex [.f configure -highlightbackground] 3] +} -result {#112233} + +test frame-13.28 {labelframe configuration options} -body { + .f configure -highlightbackground ugly +} -returnCodes error -match glob -result {*: unknown color name "ugly"} + +test frame-13.29 {labelframe configuration options} -body { + .f configure -highlightcolor #123456 + lindex [.f configure -highlightcolor] 4 +} -cleanup { + .f configure -highlightcolor [lindex [.f configure -highlightcolor] 3] +} -result {#123456} + +test frame-13.30 {labelframe configuration options} -body { + .f configure -highlightcolor non-existent +} -returnCodes error -match glob -result {*: unknown color name "non-existent"} + +test frame-13.31 {labelframe configuration options} -body { + .f configure -highlightthickness 6 + lindex [.f configure -highlightthickness] 4 +} -cleanup { + .f configure -highlightthickness [lindex [.f configure -highlightthickness] 3] +} -result {6} + +test frame-13.32 {labelframe configuration options} -body { + .f configure -highlightthickness badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} + +test frame-13.33 {labelframe configuration options} -body { + .f configure -labelanchor se + lindex [.f configure -labelanchor] 4 +} -cleanup { + .f configure -labelanchor [lindex [.f configure -labelanchor] 3] +} -result {se} + +test frame-13.34 {labelframe configuration options} -body { + .f configure -labelanchor badValue +} -returnCodes error -match glob -result {*: bad labelanchor "badValue": must be e, en, es, n, ne, nw, s, se, sw, w, wn, or ws} + +test frame-13.35 {labelframe configuration options} -body { + .f configure -padx 3 + lindex [.f configure -padx] 4 +} -cleanup { + .f configure -padx [lindex [.f configure -padx] 3] +} -result {3} + +test frame-13.36 {labelframe configuration options} -body { + .f configure -padx badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} + +test frame-13.37 {labelframe configuration options} -body { + .f configure -pady 4 + lindex [.f configure -pady] 4 +} -cleanup { + .f configure -pady [lindex [.f configure -pady] 3] +} -result {4} + +test frame-13.38 {labelframe configuration options} -body { + .f configure -pady badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} + +test frame-13.39 {labelframe configuration options} -body { + .f configure -relief ridge + lindex [.f configure -relief] 4 +} -cleanup { + .f configure -relief [lindex [.f configure -relief] 3] +} -result {ridge} + +test frame-13.40 {labelframe configuration options} -body { + .f configure -relief badValue +} -returnCodes error -match glob -result {*: bad relief "badValue": must be flat, groove, raised, ridge, solid, or sunken} + +test frame-13.41 {labelframe configuration options} -body { + .f configure -takefocus {any string} + lindex [.f configure -takefocus] 4 +} -cleanup { + .f configure -takefocus [lindex [.f configure -takefocus] 3] +} -result {any string} + +test frame-13.42 {labelframe configuration options} -body { + .f configure -text {any string} + lindex [.f configure -text] 4 +} -cleanup { + .f configure -text [lindex [.f configure -text] 3] +} -result {any string} + +test frame-13.43 {labelframe configuration options} -body { + .f configure -width 32 + lindex [.f configure -width] 4 +} -cleanup { + .f configure -width [lindex [.f configure -width] 3] +} -result {32} + +test frame-13.44 {labelframe configuration options} -body { + .f configure -width badValue +} -returnCodes error -match glob -result {*: bad screen distance "badValue"} +destroy .f + +test frame-14.1 {labelframe labelwidget option} -setup { + deleteWindows +} -body { + # Test that label is moved in stacking order + label .l -text Mupp -font {helvetica 8} + ::tko::labelframe .f -labelwidget .l + pack .f + ::tko::frame .f.f -width 50 -height 50 + pack .f.f + update + list [winfo children .] [winfo width .f] \ + [expr {[winfo height .f] - [winfo height .l]}] +} -cleanup { + deleteWindows +} -result {{.f .l} 54 52} + +test frame-14.2 {labelframe labelwidget option} -setup { + deleteWindows +} -body { + # Test the labelframe's reaction if the label is destroyed + label .l -text Aratherlonglabel + ::tko::labelframe .f -labelwidget .l + pack .f + label .f.l -text Mupp + pack .f.l + update + set res [list [.f cget -labelwidget]] + lappend res [expr {[winfo width .f] - [winfo width .l]}] + destroy .l + lappend res [.f cget -labelwidget] + update + lappend res [expr {[winfo width .f] - [winfo width .f.l]}] +} -cleanup { + deleteWindows +} -result {.l 12 {} 4} + +test frame-14.3 {labelframe labelwidget option} -setup { + deleteWindows +} -body { + # Test the labelframe's reaction if the label is stolen + label .l -text Aratherlonglabel + ::tko::labelframe .f -labelwidget .l + pack .f + label .f.l -text Mupp + pack .f.l + update + set res [list [.f cget -labelwidget]] + lappend res [expr {[winfo width .f] - [winfo width .l]}] + pack .l + lappend res [.f cget -labelwidget] + update + lappend res [expr {[winfo width .f] - [winfo width .f.l]}] +} -cleanup { + deleteWindows +} -result {.l 12 {} 4} + +test frame-14.4 {labelframe labelwidget option} -setup { + deleteWindows +} -body { + # Test the label's reaction if the labelframe is destroyed + label .l -text Mupp + ::tko::labelframe .f -labelwidget .l + pack .f + update + set res [list [winfo manager .l]] + destroy .f + lappend res [winfo manager .l] +} -cleanup { + deleteWindows +} -result {labelframe {}} + +test frame-14.5 {labelframe labelwidget option} -setup { + deleteWindows +} -body { + # Test that the labelframe reacts on changes in label + label .l -text Aratherlonglabel + ::tko::labelframe .f -labelwidget .l + pack .f + label .f.l -text Mupp + pack .f.l + update + set first [winfo width .f] + set res [expr {[winfo width .f] - [winfo width .l]}] + .l configure -text Shorter + update + lappend res [expr {[winfo width .f] - [winfo width .l]}] + lappend res [expr {[winfo width .f] < $first}] + .l configure -text Alotlongerthananytimebefore + update + lappend res [expr {[winfo width .f] - [winfo width .l]}] + lappend res [expr {[winfo width .f] > $first}] +} -cleanup { + deleteWindows +} -result {12 12 1 12 1} + +test frame-14.6 {labelframe labelwidget option} -setup { + deleteWindows +} -body { + # Destroying a labelframe with a child label caused a crash + # when not handling mapping of the label correctly. + # This test does not test anything directly, it's just ment + # to catch if the same mistake is made again. + ::tko::labelframe .f + pack .f + label .f.l -text Mupp + .f configure -labelwidget .f.l + update +} -cleanup { + deleteWindows +} -result {} + +test frame-15.1 {TIP 262: frame background images} -setup { + deleteWindows + image create photo gorp -width 10 -height 10 + gorp put black -to 2 2 7 7 +} -body { + ::tko::frame .f -width 100 -height 100 + pack .f + list [image inuse gorp] [.f configure -backgroundimage gorp;update] \ + [image inuse gorp] [winfo width .f] [winfo height .f] +} -cleanup { + image delete gorp + deleteWindows +} -result {0 {} 1 100 100} +test frame-15.2 {TIP 262: frame background images} -setup { + deleteWindows + catch {rename gorp ""} +} -body { + ::tko::frame .f -width 100 -height 100 + pack .f + update + .f configure -backgroundimage gorp +} -returnCodes error -cleanup { + deleteWindows +} -match glob -result {* image "gorp" doesn't exist} +test frame-15.3 {TIP 262: frame background images} -setup { + deleteWindows + image create photo gorp -width 10 -height 10 + gorp put black -to 2 2 7 7 +} -body { + ::tko::frame .f -width 100 -height 100 -backgroundimage gorp + pack .f + .f configure -tile yes + update + list [.f cget -bgimg] [.f cget -tile] +} -cleanup { + image delete gorp + deleteWindows +} -result {gorp 1} +test frame-15.4 {TIP 262: frame background images} -setup { + deleteWindows + image create photo gorp -width 10 -height 10 + gorp put black -to 2 2 7 7 +} -body { + ::tko::frame .f -width 100 -height 100 -backgroundimage gorp + pack .f + .f configure -tile yes + update + gorp put red -to 15 15 20 20 + update + list [.f cget -bgimg] [.f cget -tile] +} -cleanup { + image delete gorp + deleteWindows +} -result {gorp 1} +test frame-15.5 {TIP 262: frame background images} -setup { + deleteWindows + image create photo gorp -width 10 -height 10 + gorp put black -to 2 2 7 7 + set result {} +} -body { + ::tko::frame .f -width 100 -height 100 -backgroundimage gorp + pack .f + .f configure -tile yes + update + image delete gorp + update + set result [list [.f cget -bgimg] [.f cget -tile]] + image create photo gorp -width 250 -height 250 + update + lappend result [.f cget -backgroundimage] +} -cleanup { + catch {image delete gorp} + deleteWindows +} -result {gorp 1 gorp} +test frame-15.6 {TIP 262: frame background images} -setup { + deleteWindows + set result {} + . configure -width 200 -height 200 +} -constraints testImageType -body { + image create test gorp -variable result + pack [::tko::frame .f -width 100 -height 100 -bgimg gorp] + update idletasks; update + return [uniq $result] +} -cleanup { + deleteWindows + catch {image delete gorp} +} -result {{gorp get} {gorp display 0 0 30 15}} +test frame-15.6a {TIP 262: frame background images (offsets)} -setup { + deleteWindows + set result {} + . configure -width 200 -height 200 +} -constraints testImageType -body { + image create test gorp -variable result + pack [::tko::frame .f -width 10 -height 10 -bgimg gorp] + update idletasks; update + # On MacOS must wait for the test image display procedure to run. + set timer [after 300 {lappend result "timedout"}] + while {"timedout" ni $result && + "gorp display 10 2 10 10" ni $result} { + vwait result + } + after cancel $timer + update idletasks; update + return [uniq $result] +} -cleanup { + deleteWindows + catch {image delete gorp} +} -result {{gorp get} {gorp display 10 2 10 10}} +test frame-15.7 {TIP 262: frame background images} -setup { + deleteWindows + set result {} + . configure -width 200 -height 200 +} -constraints testImageType -body { + image create test gorp -variable result + pack [::tko::frame .f -width 50 -height 25 -bgimg gorp -tile 1] + update idletasks; update + # On MacOS must wait for the test image display procedure to run. + set timer [after 300 {lappend result "timedout"}] + while {"timedout" ni $result && + "gorp display 0 0 20 10" ni $result} { + vwait result + } + after cancel $timer + if {[lindex $result end] eq "timedout"} { + return [lreplace $result end end] + } + return [uniq $result] +} -cleanup { + deleteWindows + catch {image delete gorp} +} -result {{gorp get} {gorp display 0 0 30 15} {gorp display 0 0 30 10} {gorp display 0 0 20 15} {gorp display 0 0 20 10}} +test frame-15.7a {TIP 262: frame background images (offsets)} -setup { + deleteWindows + set result {} + . configure -width 200 -height 200 +} -constraints testImageType -body { + image create test gorp -variable result + pack [::tko::frame .f -width 50 -height 25 -bgimg gorp -tile 1 -highlightthick 1] + update idletasks; update + # On MacOS must wait for the test image display procedure to run. + set timer [after 300 {lappend result "timedout"}] + while {"timedout" ni $result && + "gorp display 0 0 18 8" ni $result} { + vwait result + } + after cancel $timer + return [uniq $result] +} -cleanup { + deleteWindows + catch {image delete gorp} +} -result {{gorp get} {gorp display 0 0 30 15} {gorp display 0 0 30 8} {gorp display 0 0 18 15} {gorp display 0 0 18 8}} +test frame-15.7b {TIP 262: frame background images (offsets)} -setup { + deleteWindows + set result {} + . configure -width 200 -height 200 +} -constraints testImageType -body { + image create test gorp -variable result + pack [::tko::frame .f -width 50 -height 25 -bgimg gorp -tile 1 -bd 2] + update idletasks; update + return [uniq $result] +} -cleanup { + deleteWindows + catch {image delete gorp} +} -result {{gorp get} {gorp display 0 0 30 15} {gorp display 0 0 30 6} {gorp display 0 0 16 15} {gorp display 0 0 16 6}} +test frame-15.7c {TIP 262: frame background images (offsets)} -setup { + deleteWindows + set result {} + . configure -width 200 -height 200 +} -constraints testImageType -body { + image create test gorp -variable result + pack [::tko::frame .f -width 50 -height 25 -bgimg gorp -tile 1 -bd 2 -highlightthick 1] + update idletasks; update + return [uniq $result] +} -cleanup { + deleteWindows + catch {image delete gorp} +} -result {{gorp get} {gorp display 0 0 30 15} {gorp display 0 0 30 4} {gorp display 0 0 14 15} {gorp display 0 0 14 4}} +test frame-15.8 {TIP 262: toplevel background images} -setup { + deleteWindows + image create photo gorp -width 10 -height 10 + gorp put black -to 2 2 7 7 +} -body { + ::tko::toplevel .t -width 100 -height 100 + update + # Used to verify that setting a background image doesn't change the widget size + set w [winfo width .t] + set h [winfo height .t] + list [image inuse gorp] [.t configure -backgroundimage gorp;update] \ + [image inuse gorp] \ + [expr {$w-[winfo width .t]}] [expr {$h-[winfo height .t]}] +} -cleanup { + image delete gorp + deleteWindows +} -result {0 {} 1 0 0} +test frame-15.9 {TIP 262: toplevel background images} -setup { + deleteWindows + catch {rename gorp ""} +} -body { + ::tko::toplevel .t -width 100 -height 100 + update + .t configure -backgroundimage gorp +} -returnCodes error -cleanup { + deleteWindows +} -match glob -result {* image "gorp" doesn't exist} +test frame-15.10 {TIP 262: toplevel background images} -setup { + deleteWindows + image create photo gorp -width 10 -height 10 + gorp put black -to 2 2 7 7 +} -body { + ::tko::toplevel .t -width 100 -height 100 -backgroundimage gorp -tile yes + update + list [.t cget -bgimg] [.t cget -tile] +} -cleanup { + image delete gorp + deleteWindows +} -result {gorp 1} +test frame-15.11 {TIP 262: toplevel background images} -setup { + deleteWindows + image create photo gorp -width 10 -height 10 + gorp put black -to 2 2 7 7 +} -body { + ::tko::toplevel .t -width 100 -height 100 -backgroundimage gorp -tile yes + update + gorp put red -to 15 15 20 20 + update + list [.t cget -bgimg] [.t cget -tile] +} -cleanup { + image delete gorp + deleteWindows +} -result {gorp 1} +test frame-15.12 {TIP 262: toplevel background images} -setup { + deleteWindows + image create photo gorp -width 10 -height 10 + gorp put black -to 2 2 7 7 + set result {} +} -body { + ::tko::toplevel .t -width 100 -height 100 -backgroundimage gorp -tile yes + update + image delete gorp + update + set result [list [.t cget -bgimg] [.t cget -tile]] + image create photo gorp -width 250 -height 250 + update + lappend result [.t cget -backgroundimage] +} -cleanup { + catch {image delete gorp} + deleteWindows +} -result {gorp 1 gorp} +test frame-15.13 {TIP 262: toplevel background images} -setup { + deleteWindows + set result {} +} -constraints testImageType -body { + image create test gorp -variable result + ::tko::toplevel .t -width 100 -height 100 -bgimg gorp + wm overrideredirect .t 1; # Reduce trouble from window managers + update idletasks; update + return [uniq $result] +} -cleanup { + deleteWindows + catch {image delete gorp} +} -result {{gorp get} {gorp display 0 0 30 15}} +test frame-15.14 {TIP 262: toplevel background images} -setup { + deleteWindows + set result {} +} -constraints testImageType -body { + image create test gorp -variable result + ::tko::toplevel .t -width 50 -height 25 -bgimg gorp -tile 1 + wm overrideredirect .t 1; # Reduce trouble from window managers + update idletasks; update + # On MacOS must wait for the test image display procedure to run. + set timer [after 300 {lappend result "timedout"}] + while {"timedout" ni $result && + "gorp display 0 0 20 10" ni $result} { + vwait result + } + after cancel $timer + return [uniq $result] +} -cleanup { + deleteWindows + catch {image delete gorp} +} -result {{gorp get} {gorp display 0 0 30 15} {gorp display 0 0 30 10} {gorp display 0 0 20 15} {gorp display 0 0 20 10}} + +# +# Test "::tko *" +# +test frame-20.1 {tko wrong args} -setup { + deleteWindows +} -body { + ::tko xy +} -cleanup { + deleteWindows +} -returnCodes error -match glob -result {bad option "xy": *} + +test frame-20.2 {tko initfrom with optionget/optionset} -setup { + deleteWindows +} -body { + oo::class create C {::tko initfrom ::tko::frame} + C .c + llength [.c configure] +} -cleanup { + deleteWindows + C destroy +} -match glob -result {21} + +test frame-20.3 {tko optiondef} -setup { + deleteWindows +} -body { + oo::class create C { + ::tko initfrom ::tko::frame + ::tko optiondef [self] -o1 {o1 O1 v1 {}} {set tko(-o1) x} + } + C .c + .c configure -o1 +} -cleanup { + deleteWindows + C destroy +} -match glob -result {-o1 o1 O1 v1 x} + +test frame-20.4 {tko optiondel} -setup { + deleteWindows +} -body { + oo::class create C { + ::tko initfrom ::tko::frame + ::tko optiondel [self] -bg -width + } + C .c + llength [.c configure] +} -cleanup { + deleteWindows + C destroy +} -match glob -result {19} + +test frame-20.5 {tko optionhide} -setup { + deleteWindows +} -body { + oo::class create C { + ::tko initfrom ::tko::frame + ::tko optionhide [self] -bg -width + } + C .c + llength [.c configure] +} -cleanup { + deleteWindows + C destroy +} -match glob -result {19} + +test frame-20.6 {tko optionshow} -setup { + deleteWindows +} -body { + oo::class create C { + ::tko initfrom ::tko::frame + ::tko optionhide [self] -background -width + ::tko optionshow [self] -bg + } + C .c + llength [.c configure] +} -cleanup { + deleteWindows + C destroy +} -match glob -result {19} + +# +# Test "my _tko .." +# +test frame-21.1 {my _tko .. wrong args} -setup { + deleteWindows +} -body { + oo::class create C { + ::tko initfrom ::tko::frame + method mycmd {args} {my {*}$args} + } + C .c + .c mycmd _tko xx +} -cleanup { + deleteWindows + C destroy +} -returnCodes error -match glob -result {bad option "xx": *} + +test frame-21.2 {my _tko optionadd} -setup { + deleteWindows +} -body { + oo::class create C { + ::tko initfrom ::tko::frame + method mycmd {args} {my {*}$args} + } + C .c + .c mycmd _tko optionadd -o1 {o1 O1 v1 {}} {variable tko; set tko(-o1) x} + .c configure -o1 +} -cleanup { + deleteWindows + C destroy +} -match glob -result {-o1 o1 O1 v1 x} + +test frame-21.3 {my _tko optiondel} -setup { + deleteWindows +} -body { + oo::class create C { + ::tko initfrom ::tko::frame + method mycmd {args} {my {*}$args} + } + C .c + .c mycmd _tko optiondel -bg -width + llength [.c configure] +} -cleanup { + deleteWindows + C destroy +} -match glob -result {19} + +test frame-21.4 {my _tko optionhide} -setup { + deleteWindows +} -body { + oo::class create C { + ::tko initfrom ::tko::frame + method mycmd {args} {my {*}$args} + } + C .c + .c mycmd _tko optionhide -bg -width + llength [.c configure] +} -cleanup { + deleteWindows + C destroy +} -match glob -result {19} + +test frame-21.5 {my _tko optionshow} -setup { + deleteWindows +} -body { + oo::class create C { + ::tko initfrom ::tko::frame + method mycmd {args} {my {*}$args} + } + C .c + .c mycmd _tko optionhide -background -width + .c mycmd _tko optionshow -bg + llength [.c configure] +} -cleanup { + deleteWindows + C destroy +} -match glob -result {19} + +test frame-21.6 {my_tko optionadd readonly} -setup { + deleteWindows +} -body { + oo::class create ::C { + ::tko initfrom ::tko::frame + method mycmd {args} {my {*}$args} + } + C .c + .c mycmd _tko optionadd -o1 {o1 O1 v1 r} {variable tko; set tko(-o1) x} + .c configure -o1 xx +} -cleanup { + deleteWindows + C destroy +} -returnCodes error -match glob -result {*option "-o1" is readonly} + +test frame-22.1 {tko initclass} -setup { + deleteWindows +} -body { + oo::class create ::C { + ::tko initclass + method mycmd {args} {my {*}$args} + } + ::C create ::c + set myList [llength [c configure]] + ::tko optiondef ::C -o1 {o1 O1 v1 {}} {set tko(-o1) x} + lappend myList [llength [c configure]] + c destroy + ::C create ::c + lappend myList [llength [c configure]] + c mycmd _tko optionadd -o2 {o2 O2 v2 {}} {variable tko; set tko(-o2) x} + lappend myList [llength [c configure]] +} -cleanup { + C destroy +} -match glob -result {0 0 1 2} + +test frame-30.1 {performance comparison} -setup { + deleteWindows +} -body { + oo::class create ::wrapframe {::tko initwrap frame {-class -colormap -container -visual} {}} + oo::class create ::wraplabelframe {::tko initwrap labelframe {-class -colormap -container -visual} {}} + proc ::TEST::Do {cmd} {set i 0; format %7.1f [lindex [time $cmd 100] 0]} + proc ::TEST::Test {wdg} { + set ret [format %15s $wdg] + append ret [::TEST::Do "$wdg .\[incr i\]"] + append ret [::TEST::Do {.[incr i] cget -width}] + append ret [::TEST::Do {.[incr i] configure -width 100}] + append ret [::TEST::Do {.[incr i] configure}] + append ret [::TEST::Do {destroy .[incr i]}] + } + puts " command create cget config list destroy" + puts [::TEST::Test ::frame] + puts [::TEST::Test ::ttk::frame] + puts [::TEST::Test ::tko::frame] + puts [::TEST::Test ::wrapframe] + puts [::TEST::Test ::labelframe] + puts [::TEST::Test ::ttk::labelframe] + puts [::TEST::Test ::tko::labelframe] + puts [::TEST::Test ::wraplabelframe] + puts [::TEST::Test ::toplevel] + puts [::TEST::Test ::tko::toplevel] +} -cleanup { + catch {::wrapframe destroy} + catch {::wraplabelframe destroy} + deleteWindows +} -result {} + + +deleteWindows +rename ::TEST::eatColors {} +rename ::TEST::colorsFree {} + +# cleanup +cleanupTests +} +catch {namespace delete ::TEST} + +# vim: set ts=4 sw=4 sts=4 ff=unix et : Index: unix/Makefile.in ================================================================== --- unix/Makefile.in +++ unix/Makefile.in @@ -310,10 +310,11 @@ RANLIB = @RANLIB@ SRC_DIR = @srcdir@ TOP_DIR = $(SRC_DIR)/.. GENERIC_DIR = $(TOP_DIR)/generic TTK_DIR = $(GENERIC_DIR)/ttk +TKO_DIR = $(GENERIC_DIR)/tko UNIX_DIR = $(TOP_DIR)/unix BMAP_DIR = $(TOP_DIR)/bitmaps TOOL_DIR = $(TCLDIR)/tools TEST_DIR = $(TOP_DIR)/tests MAC_OSX_DIR = $(TOP_DIR)/macosx @@ -384,10 +385,13 @@ ttkPanedwindow.o ttkProgress.o ttkScale.o ttkScrollbar.o ttkScroll.o \ ttkSeparator.o ttkSquare.o ttkState.o \ ttkTagSet.o ttkTheme.o ttkTrace.o ttkTrack.o ttkTreeview.o \ ttkWidget.o ttkStubInit.o +TKO_OBJS = \ + tkoWidget.o tkoFrame.o + STUB_OBJS = tkStubInit.o STUB_LIB_OBJS = tkStubLib.o ttkStubLib.o X11_OBJS = tkUnix.o tkUnix3d.o tkUnixButton.o tkUnixColor.o tkUnixConfig.o \ @@ -410,11 +414,11 @@ ttkMacOSXTheme.o AQUA_TKTEST_OBJS = tkMacOSXTest.o OBJS = $(GENERIC_OBJS) $(WIDG_OBJS) $(CANV_OBJS) $(IMAGE_OBJS) $(TEXT_OBJS) \ - $(STUB_OBJS) $(TTK_OBJS) \ + $(STUB_OBJS) $(TTK_OBJS) $(TKO_OBJS)\ $(@TK_WINDOWINGSYSTEM@_OBJS) @PLAT_OBJS@ TK_DECLS = \ $(GENERIC_DIR)/tk.decls \ $(GENERIC_DIR)/tkInt.decls @@ -498,10 +502,13 @@ $(TTK_DIR)/ttkWidget.c TTK_STUB_SRCS = \ $(TTK_DIR)/ttkStubInit.c $(TTK_DIR)/ttkStubLib.c +TKO_SRCS = \ + $(TKO_DIR)/tkoWidget.c $(TKO_DIR)/tkoFrame.c + X11_SRCS = \ $(UNIX_DIR)/tkAppInit.c $(UNIX_DIR)/tkUnix.c \ $(UNIX_DIR)/tkUnix3d.c \ $(UNIX_DIR)/tkUnixButton.c $(UNIX_DIR)/tkUnixColor.c \ $(UNIX_DIR)/tkUnixConfig.c \ @@ -717,18 +724,22 @@ # isn't the same as the source directory. # Specifying TESTFLAGS on the command line is the standard way to pass # args to tcltest, ie: # % make test TESTFLAGS="-verbose bps -file fileName.test" -test: test-classic test-ttk +test: test-classic test-ttk test-tko test-classic: $(TKTEST_EXE) $(SHELL_ENV) ./$(TKTEST_EXE) $(TEST_DIR)/all.tcl -geometry +0+0 $(TESTFLAGS) test-ttk: $(TKTEST_EXE) $(SHELL_ENV) ./$(TKTEST_EXE) $(TEST_DIR)/ttk/all.tcl -geometry +0+0 \ $(TESTFLAGS) + +test-tko: $(TKTEST_EXE) + $(SHELL_ENV) ./$(TKTEST_EXE) $(TEST_DIR)/tko/all.tcl -geometry +0+0 \ + $(TESTFLAGS) # Tests with different languages testlang: $(TKTEST_EXE) $(SHELL_ENV) \ for lang in $(LOCALES) ; \ @@ -1591,10 +1602,16 @@ tkUuid.h: $(TOP_DIR)/manifest.uuid echo "#define TK_VERSION_UUID \\" >$@ cat $(TOP_DIR)/manifest.uuid >>$@ echo "" >>$@ +tkoWidget.o: $(TKO_DIR)/tkoWidget.c + $(CC) -c $(CC_SWITCHES) $(TKO_DIR)/tkoWidget.c + +tkoFrame.o: $(TKO_DIR)/tkoFrame.c + $(CC) -c $(CC_SWITCHES) $(TKO_DIR)/tkoFrame.c + .c.o: $(CC) -c $(CC_SWITCHES) $< # # Target to regenerate header files and stub files from the *.decls tables. Index: win/Makefile.in ================================================================== --- win/Makefile.in +++ win/Makefile.in @@ -100,10 +100,11 @@ TOP_DIR = $(shell cd @srcdir@/..; pwd -W 2>/dev/null || pwd -P) WIN_DIR = $(TOP_DIR)/win UNIX_DIR = $(TOP_DIR)/unix GENERIC_DIR = $(TOP_DIR)/generic TTK_DIR = $(GENERIC_DIR)/ttk +TKO_DIR = $(GENERIC_DIR)/tko BITMAP_DIR = $(TOP_DIR)/bitmaps XLIB_DIR = $(TOP_DIR)/xlib RC_DIR = $(WIN_DIR)/rc # Converts a POSIX path to a Windows native path. @@ -154,11 +155,11 @@ # Setting the VPATH variable to a list of paths will cause the # makefile to look into these paths when resolving .c to .obj # dependencies. -VPATH = $(GENERIC_DIR):$(TTK_DIR):$(WIN_DIR):$(XLIB_DIR):$(RC_DIR) +VPATH = $(GENERIC_DIR):$(TTK_DIR):$(TKO_DIR):$(WIN_DIR):$(XLIB_DIR):$(RC_DIR) # warning flags CFLAGS_WARNING = @CFLAGS_WARNING@ # The default switches for optimization or debugging @@ -402,11 +403,12 @@ tkUndo.$(OBJEXT) \ tkUtil.$(OBJEXT) \ tkVisual.$(OBJEXT) \ tkStubInit.$(OBJEXT) \ tkWindow.$(OBJEXT) \ - $(TTK_OBJS) + $(TTK_OBJS) \ + $(TKO_OBJS) TTK_OBJS = \ ttkWinMonitor.$(OBJEXT) \ ttkWinTheme.$(OBJEXT) \ ttkWinXPTheme.$(OBJEXT) \ @@ -439,10 +441,14 @@ ttkTrack.$(OBJEXT) \ ttkTreeview.$(OBJEXT) \ ttkWidget.$(OBJEXT) \ ttkStubInit.$(OBJEXT) +TKO_OBJS = \ + tkoWidget.$(OBJEXT) \ + tkoFrame.$(OBJEXT) + STUB_OBJS = \ tkStubLib.$(OBJEXT) \ ttkStubLib.$(OBJEXT) TCL_DOCS = "$(TCL_SRC_DIR_NATIVE)/doc/*.[13n]" @@ -481,19 +487,23 @@ # Specifying TESTFLAGS on the command line is the standard way to pass # args to tcltest, ie: # % make test TESTFLAGS="-verbose bps -file fileName.test" -test: test-classic test-ttk +test: test-classic test-ttk test-tko test-classic: binaries $(TKTEST) $(TEST_DLL_FILE) $(CAT32) $(SHELL_ENV) $(WINE) ./$(TKTEST) "$(ROOT_DIR_NATIVE)/tests/all.tcl" \ $(TESTFLAGS) | $(WINE) ./$(CAT32) test-ttk: binaries $(TKTEST) $(TEST_DLL_FILE) $(CAT32) $(SHELL_ENV) $(WINE) ./$(TKTEST) "$(ROOT_DIR_NATIVE)/tests/ttk/all.tcl" \ $(TESTFLAGS) | $(WINE) ./$(CAT32) + +test-tko: binaries $(TKTEST) $(TEST_DLL_FILE) $(CAT32) + $(SHELL_ENV) $(WINE) ./$(TKTEST) "$(ROOT_DIR_NATIVE)/tests/tko/all.tcl" \ + $(TESTFLAGS) | $(WINE) ./$(CAT32) runtest: binaries $(TKTEST) $(TEST_DLL_FILE) $(SHELL_ENV) $(WINE) ./$(TKTEST) $(TESTFLAGS) $(SCRIPT) # This target can be used to run wish from the build directory Index: win/makefile.vc ================================================================== --- win/makefile.vc +++ win/makefile.vc @@ -284,10 +284,11 @@ $(TMP_DIR)\tkUtil.obj \ $(TMP_DIR)\tkVisual.obj \ $(TMP_DIR)\tkStubInit.obj \ $(TMP_DIR)\tkWindow.obj \ $(TTK_OBJS) \ + $(TKO_OBJS) \ !if !$(STATIC_BUILD) $(TMP_DIR)\tk.res !endif TTK_OBJS = \ @@ -323,18 +324,23 @@ $(TMP_DIR)\ttkTrack.obj \ $(TMP_DIR)\ttkTreeview.obj \ $(TMP_DIR)\ttkWidget.obj \ $(TMP_DIR)\ttkStubInit.obj +TKO_OBJS = \ + $(TMP_DIR)\tkoWidget.obj \ + $(TMP_DIR)\tkoFrame.obj + TKSTUBOBJS = \ $(TMP_DIR)\tkStubLib.obj \ $(TMP_DIR)\ttkStubLib.obj ### The following paths CANNOT have spaces in them as they appear on ### the left side of implicit rules. XLIBDIR = $(ROOT)\xlib TTKDIR = $(ROOT)\generic\ttk +TKODIR = $(ROOT)\generic\tko BITMAPDIR = $(ROOT)\bitmaps # Directories where to build TIP430 ZIP files # One for Tk - always built, contains Tk scripts # One for Wish - for static builds, contains Tcl+Tk scripts @@ -688,11 +694,12 @@ @echo Build tclsh first! !else set TCL_LIBRARY=$(TCL_LIBRARY) $(TCLSH) $(TCLTOOLSDIR:\=/)/mkdepend.tcl -vc32 -out:"$(OUT_DIR)\depend.mk" \ -passthru:"/DBUILD_tk $(TK_INCLUDES)" $(GENERICDIR),$$(GENERICDIR) \ - $(WIN_DIR),$$(WIN_DIR) $(TTKDIR),$$(TTKDIR) $(XLIBDIR),$$(XLIBDIR) \ + $(WIN_DIR),$$(WIN_DIR) $(TTKDIR),$$(TTKDIR) $(TKODIR),$$(TKODIR) \ + $(XLIBDIR),$$(XLIBDIR) \ $(BITMAPDIR),$$(BITMAPDIR) @<< $(TKOBJS) << !endif @@ -727,10 +734,15 @@ {$(TTKDIR)}.c{$(TMP_DIR)}.obj:: $(CCPKGCMD) @<< $< << +{$(TKODIR)}.c{$(TMP_DIR)}.obj:: + $(CCPKGCMD) @<< +$< +<< + {$(ROOT)\unix}.c{$(TMP_DIR)}.obj:: $(CCPKGCMD) @<< $< <<