Index: .github/workflows/linux-with-tcl8-build.yml ================================================================== --- .github/workflows/linux-with-tcl8-build.yml +++ .github/workflows/linux-with-tcl8-build.yml @@ -30,11 +30,11 @@ path: tk - name: Checkout Tcl uses: actions/checkout@v3 with: repository: tcltk/tcl - ref: core-8-branch + ref: tip-558 path: tcl - name: Setup Environment (compiler=${{ matrix.compiler }}) run: | sudo apt-get install libxss-dev mkdir "$HOME/install dir" @@ -133,11 +133,11 @@ path: tk - name: Checkout Tcl uses: actions/checkout@v3 with: repository: tcltk/tcl - ref: core-8-branch + ref: tip-558 path: tcl - name: Setup Environment (compiler=${{ matrix.compiler }}) run: | sudo apt-get install libxss-dev xvfb libicu-dev mkdir "$HOME/install dir" Index: .github/workflows/onefiledist.yml ================================================================== --- .github/workflows/onefiledist.yml +++ .github/workflows/onefiledist.yml @@ -19,11 +19,11 @@ path: tk - name: Checkout Tcl 8.7 uses: actions/checkout@v3 with: repository: tcltk/tcl - ref: core-8-branch + ref: tip-558 path: tcl - name: Setup Environment run: | sudo apt-get install libxss-dev touch tcl/generic/tclStubInit.c tcl/generic/tclOOStubInit.c @@ -83,11 +83,11 @@ path: tk - name: Checkout Tcl 8.7 uses: actions/checkout@v3 with: repository: tcltk/tcl - ref: core-8-branch + ref: tip-558 path: tcl - name: Checkout create-dmg uses: actions/checkout@v3 with: repository: create-dmg/create-dmg @@ -171,11 +171,11 @@ path: tk - name: Checkout Tcl 8.7 uses: actions/checkout@v3 with: repository: tcltk/tcl - ref: core-8-branch + ref: tip-558 path: tcl - name: Setup Environment run: | mkdir -p install/combined touch tcl/generic/tclStubInit.c tcl/generic/tclOOStubInit.c Index: .github/workflows/win-build.yml ================================================================== --- .github/workflows/win-build.yml +++ .github/workflows/win-build.yml @@ -19,11 +19,11 @@ path: tk - name: Checkout uses: actions/checkout@v3 with: repository: tcltk/tcl - ref: core-8-branch + ref: tip-558 path: tcl - name: Init MSVC uses: ilammy/msvc-dev-cmd@v1 - name: Make Install Location working-directory: tcl Index: doc/option.n ================================================================== --- doc/option.n +++ doc/option.n @@ -13,11 +13,11 @@ option \- Add/retrieve window options to/from the option database .SH SYNOPSIS .nf \fBoption add \fIpattern value \fR?\fIpriority\fR? \fBoption clear\fR -\fBoption get \fIwindow name class\fR +\fBoption get \fIwindow name class\fR ?\fIdefault\fR? \fBoption readfile \fIfileName \fR?\fIpriority\fR? .fi .BE .SH DESCRIPTION .PP @@ -48,11 +48,15 @@ database match \fIwindow\fR, \fIname\fR, and \fIclass\fR, then the command returns whichever was created with highest \fIpriority\fR level. If there are several matching entries at the same priority level, then it returns whichever entry was most recently entered into the option database. If there are -no matching entries, then the empty string is returned. +no matching entries, then +.VS TIP560 +either \fIdefault\fR is returned if it is specified, or otherwise +.VE TIP 560 +the empty string is returned. .PP The \fBreadfile\fR form of the command reads \fIfileName\fR, which should have the standard format for an X resource database such as \fB.Xdefaults\fR, and adds all the options specified in that file to the option database. If \fIpriority\fR Index: generic/tkCursor.c ================================================================== --- generic/tkCursor.c +++ generic/tkCursor.c @@ -816,10 +816,70 @@ Tcl_InitHashTable(&dispPtr->cursorIdTable, TCL_ONE_WORD_KEYS); dispPtr->cursorInit = 1; } + +/* + *---------------------------------------------------------------------- + * + * TkParseCursorObjCmd -- + * + * Implements [tk::ParseCursor]. Parses a cursor and returns either the + * empty string if the cursor (named in the first argument) is valid, or + * an error if the cursor is not actually a cursor. The cursor is not + * actually stored anywhere afterwards. + * + * Results: + * A Tcl result code. + * + * Side effects: + * Sets the interpreter result and error code on error. + * + *---------------------------------------------------------------------- + */ + +int +TkParseCursorObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tk_Window tkwin = clientData; + Tk_Cursor cursor; + Tcl_Obj *cursorObj; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "cursor"); + return TCL_ERROR; + } + cursorObj = objv[1]; + + /* + * Type poke so that we don't need to do memory management if something + * else has done it for us. In theory this could be a problem if the main + * display couldn't have the cursor that this object describes... but that + * never actually happens. + */ + + if (cursorObj->typePtr == &tkCursorObjType) { + return TCL_OK; + } + + /* + * Not already a cursor. Engage the parser (and clean up destructively + * afterwards). + */ + + cursor = Tk_AllocCursorFromObj(interp, tkwin, cursorObj); + if (!cursor) { + return TCL_ERROR; + } + Tk_FreeCursorFromObj(tkwin, cursorObj); + return TCL_OK; +} /* *---------------------------------------------------------------------- * * TkDebugCursor -- Index: generic/tkInt.h ================================================================== --- generic/tkInt.h +++ generic/tkInt.h @@ -192,11 +192,11 @@ * longer valid and it isn't present in a hash * table: it is being kept around only because * there are objects referring to it. The * structure is freed when resourceRefCount * and objRefCount are both 0. */ - TkSizeT objRefCount; /* Number of Tcl objects that reference this + TkSizeT objRefCount; /* Number of Tcl objects that reference this * structure.. */ Tcl_HashTable *otherTable; /* Second table (other than idTable) used to * index this entry. */ Tcl_HashEntry *hashPtr; /* Entry in otherTable for this structure * (needed when deleting). */ @@ -1496,15 +1496,16 @@ */ MODULE_SCOPE int TkUnsupported1ObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_ObjCmdProc TkParseCursorObjCmd; /* * For Tktest. */ -MODULE_SCOPE int SquareObjCmd(ClientData clientData, +MODULE_SCOPE int SquareObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj * const objv[]); MODULE_SCOPE int TkOldTestInit(Tcl_Interp *interp); #if !(defined(_WIN32) || defined(MAC_OSX_TK)) #define TkplatformtestInit(x) TCL_OK Index: generic/tkOption.c ================================================================== --- generic/tkOption.c +++ generic/tkOption.c @@ -677,12 +677,12 @@ case OPTION_GET: { Tk_Window window; Tk_Uid value; - if (objc != 5) { - Tcl_WrongNumArgs(interp, 2, objv, "window name class"); + if (objc != 5 && objc != 6) { + Tcl_WrongNumArgs(interp, 2, objv, "window name class ?default?"); return TCL_ERROR; } window = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), tkwin); if (window == NULL) { return TCL_ERROR; @@ -689,10 +689,12 @@ } value = Tk_GetOption(window, Tcl_GetString(objv[3]), Tcl_GetString(objv[4])); if (value != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(value, -1)); + } else if (objc == 6) { + Tcl_SetObjResult(interp, objv[5]); } break; } case OPTION_READFILE: { Index: generic/tkWindow.c ================================================================== --- generic/tkWindow.c +++ generic/tkWindow.c @@ -192,10 +192,11 @@ /* * Misc. */ + {"::tk::ParseCursor", TkParseCursorObjCmd, PASSMAINWINDOW|ISSAFE}, #ifdef MAC_OSX_TK {"::tk::unsupported::MacWindowStyle", TkUnsupported1ObjCmd, PASSMAINWINDOW|ISSAFE}, #endif {NULL, NULL, 0} ADDED library/oocfg.tcl Index: library/oocfg.tcl ================================================================== --- /dev/null +++ library/oocfg.tcl @@ -0,0 +1,934 @@ +# oocfg.tcl -- +# +# This file contains a configure system for megawidgets written in TclOO. +# +# Copyright (c) 2020 Donal K. Fellows +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +# 8.7, or any 9.* +package require Tcl 8.7-9.99 + +namespace eval ::tk { + # ---------------------------------------------------------------------- + # + # tk::OptionDefine -- + # + # The definition language namespace for configurable widget definitions. + # All actual implementations of bits and pieces are in the subordinate + # Support namespace, and the public API then namespace export/import-ed + # into the main namespace (which has its path set up to be a definition + # language). + # + # ---------------------------------------------------------------------- + + namespace eval OptionDefine { + namespace eval Support { + namespace ensemble create -command ::tk::OptionType + namespace path {::tcl ::tk ::oo::configuresupport} + + # -------------------------------------------------------------- + # + # tk::OptionDefine::Support::DefineOption -- + # + # Actually defines an option. Assumes all validation of + # arguments has been done. + # + # -------------------------------------------------------------- + + proc DefineOption {name options} { + set descriptor ::list + lappend descriptor [dict get $options name] + lappend descriptor [dict get $options class] + set type [dict get $options type] + if {[dict exists $options def]} { + lappend descriptor [dict get $options def] + } else { + lappend descriptor [OptionType $type default] + } + set validator [list [namespace which OptionType] $type validate] + + uplevel 1 [list \ + method {} $descriptor] + uplevel 1 [list \ + forward {*}$validator] + + # We only make the access methods if they don't exist on this + # class; this allows a user to override them before defining + # the option. + + set meths [info class methods [uplevel 1 self] -scope unexported] + if {"" ni $meths} { + uplevel 1 [list \ + forward my $name] + } + + # Note: init-only options still have this + if {"" ni $meths} { + uplevel 1 [list \ + forward my $name] + } + + uplevel 1 [list \ + [namespace which readableproperties] -append -$name] + if {![dict get $options init]} { + uplevel 1 [list \ + [namespace which writableproperties] -append -$name] + } + } + + # -------------------------------------------------------------- + # + # tk::OptionDefine::Support::ListOptions -- + # + # Shorthand for getting the list of all options of a class of a + # given type. + # + # -------------------------------------------------------------- + + proc ListOptions {class {type -readable}} { + tailcall info class properties $class -all $type + } + + # -------------------------------------------------------------- + # + # tk::OptionDefine::Support::DefineAlias -- + # + # Actually defines a option alias. Does minor validation of its + # target, checking that it actually exists and is not an + # init-only option (because otherwise things get weird). + # + # -------------------------------------------------------------- + + proc DefineAlias {contextClass name otherName} { + if {[string index $otherName 0] ne "-"} { + set otherName "-$otherName" + } + if {$otherName ni [ListOptions $contextClass]} { + throw [list TK LOOKUP OPTION $otherName] \ + "no such option \"$otherName\"" + } + if {$otherName ni [ListOptions $contextClass -writable]} { + throw [list TK LOOKUP OPTION $otherName] \ + "may not alias init-only option \"$otherName\"" + } + set descriptor [list ::list $otherName] + + uplevel 1 [list \ + method {} $descriptor] + uplevel 1 [list \ + forward my ] + + # Aliases always define readers and writers; overriding them + # makes no sense at all! + uplevel 1 [list \ + forward my ] + uplevel 1 [list \ + forward my ] + + uplevel 1 [list \ + [namespace which readableproperties] -append -$name] + uplevel 1 [list \ + [namespace which writableproperties] -append -$name] + } + + # -------------------------------------------------------------- + # + # tk::OptionDefine::Support::ParseOptionArgs -- + # + # Parses the various options to the [option] definition + # command. + # + # -------------------------------------------------------------- + + proc ParseOptionArgs {name args} { + dict set opt type string + dict set opt class [string totitle $name] + dict set opt name [string tolower $name] + dict set opt init false + set defFromType [OptionType string default] + foreach {option value} $args { + switch [prefix match { + -alias -class -default -initonly -name -type + } $option] { + -alias { + if {[llength $args] != 2} { + throw {TK OPTION_MISUSE} \ + "-alias may only ever be used on its own" + } + dict set opt alias $value + } + -class { + if {![regexp {^[[:upper:]][[:alnum:]_]*$} $value]} { + throw {TK OPTION_MISUSE} \ + "-class must be alphanumeric with a leading capital letter" + } + dict set opt class $value + } + -name { + if {![regexp {^[[:lower:]][[:alnum:]_]*$} $value]} { + throw {TK OPTION_MISUSE} \ + "-name must be alphanumeric with a leading lower-case letter" + } + dict set opt name $value + } + -default { + # Can only validate this once we know the type + dict set opt def $value + } + -initonly { + # Use our existing boolean validator + dict set opt init \ + [OptionType boolean validate $value] + } + -type { + dict set opt type $value + set defFromType [OptionType $value default] + } + } + } + if {[dict exists $opt def]} { + # Apply the type validation to the default + dict set opt def [OptionType [dict get $opt type] validate \ + [dict get $opt def]] + } else { + dict set opt def $defFromType + } + return $opt + } + + # -------------------------------------------------------------- + # + # tk::OptionDefine::Support::option -- + # + # The implementation of the [option] definition. Mostly + # delegates to other procedures in this namespace. + # + # -------------------------------------------------------------- + + proc option {name args} { + set contextClass [uplevel 1 self] + if {[llength $args] % 2} { + return -code error -errorcode {TCL WRONGARGS} \ + [format {wrong # args: should be "%s"} \ + "option name ?-option value ...?"] + } + if {![regexp -nocase {^[[:alpha:]][[:alnum:]_]*$} $name]} { + return -code error -errorcode {TK OPTION_NAME} \ + "bad option name \"$name\":\ + must be alphanumeric starting with a letter" + } + try { + set Opt [ParseOptionArgs $name {*}$args] + if {[dict exists $Opt alias]} { + uplevel 1 [list \ + [namespace which DefineAlias] $contextClass $name \ + [dict get $Opt alias]] + } else { + uplevel 1 [list \ + [namespace which DefineOption] $name $Opt] + } + } on error {msg opt} { + # Condition the errorinfo trace + dict unset opt -errorinfo + dict incr opt -level + return -options $opt $msg + } + } + + namespace export option + } + + proc superclass args { + set support ::tk::ConfigurableStandardImplementations + uplevel 1 [list ::oo::define::superclass {*}$args] + tailcall ::oo::define::superclass -appendifnew $support + } + + namespace import Support::option + namespace export option + namespace path ::oo::define + } + + # ---------------------------------------------------------------------- + # + # tk::Configurable -- + # + # The (mixin) class for configurable widgets. + # + # Tricky point: namespace path of classes is uncertain; fully qualify + # everything. + # + # ---------------------------------------------------------------------- + + ::oo::class create Configurable { + private { + variable initialised + + # -------------------------------------------------------------- + # + # tk::Configurable Options -- + # + # Get the list of readable options of the object. + # + # -------------------------------------------------------------- + + method ReadableOptions {} { + ::info object properties [self] -all -readable + } + + # -------------------------------------------------------------- + # + # tk::Configurable WritableOptions -- + # + # Get the list of writable (after initialisation) options of the + # object. + # + # -------------------------------------------------------------- + + method WritableOptions {} { + ::info object properties [self] -all -writable + } + + # -------------------------------------------------------------- + # + # tk::Configurable GetRealOptionName -- + # + # Expand unique prefixes of an option. + # + # -------------------------------------------------------------- + + method GetRealOptionName {option} { + ::try { + ::return [::tcl::prefix match -message "option" \ + [my ReadableOptions] $option] + } on error msg { + # Convert errorCode + ::throw [::list TK LOOKUP OPTION $option] $msg + } + } + + # -------------------------------------------------------------- + # + # tk::Configurable DescribeOption -- + # + # Describes a single option (called from AllDescriptors and + # OneDescriptor). The option name must be in its full form. + # + # -------------------------------------------------------------- + + method DescribeOption {option} { + ::set desc [my ] + ::if {[::llength $desc] == 1} { + ::list $option {*}$desc + } else { + ::list $option {*}$desc [my ] + } + } + + # -------------------------------------------------------------- + # + # tk::Configurable AllDescriptors -- + # + # Implements [$obj configure] with no extra arguments. + # + # -------------------------------------------------------------- + + method AllDescriptors {} { + ::lmap opt [my ReadableOptions] {my DescribeOption $opt} + } + + # -------------------------------------------------------------- + # + # tk::Configurable OneDescriptor -- + # + # Implements [$obj configure -opt] with no extra arguments. + # + # -------------------------------------------------------------- + + method OneDescriptor {option} { + my DescribeOption [my GetRealOptionName $option] + } + + # -------------------------------------------------------------- + # + # tk::Configurable UpdateState -- + # + # Implements [$obj configure -opt val -opt val...]. + # + # -------------------------------------------------------------- + + method UpdateState arguments { + ::set opts [my WritableOptions] + ::set stateChanged 0 + ::set checkpoint [my ] + ::try { + ::foreach {option value} $arguments { + try { + ::set opt [::tcl::prefix match -message "option" \ + $opts $option] + } on error {msg} { + ::try { + ::tcl::prefix match [my ReadableOptions] $option + } on error {} { + # Do nothing + } on ok {optionName} { + ::set msg "read only option: $optionName" + } + ::throw [::list TK LOOKUP OPTION $option] $msg + } + set value [my $value] + my $value + ::set stateChanged 1 + } + ::if {$stateChanged} { + my PostConfigure + } + ::unset -nocomplain checkpoint + } finally { + # Rollback on error + ::if {[::info exists checkpoint]} { + my $checkpoint + } + } + } + } + + # ------------------------------------------------------------------ + # + # tk::Configurable configure -- + # + # Implements [$obj configure ...]. + # + # ------------------------------------------------------------------ + + method configure args { + ::try { + ::if {[::llength $args] == 0} { + ::return [my AllDescriptors] + } elseif {[::llength $args] == 1} { + ::return [my OneDescriptor [::lindex $args 0]] + } elseif {[::llength $args] % 2 == 0} { + my UpdateState $args + ::return + } else { + # Don't like the genuine Tk errors; they're weird! + ::throw {TCL WRONGARGS} \ + [::format {wrong # args: should be "%s %s"} \ + [lindex [info level 0] 0] \ + "configure ?-option value ...?"] + } + } on error {msg opt} { + # Hide the implementation details + ::dict unset opt -errorinfo + ::dict incr opt -level + ::return -options $opt $msg + } + } + + # ------------------------------------------------------------------ + # + # tk::Configurable cget -- + # + # Implements [$obj cget $option]. + # + # ------------------------------------------------------------------ + + method cget {option} { + ::try { + ::return [my ] + } on error {msg opt} { + # Hide the implementation details + ::dict unset opt -errorinfo + ::dict incr opt -level + ::return -options $opt $msg + } + } + + # ------------------------------------------------------------------ + # + # tk::Configurable Initialise -- + # + # Initialisation version of [$obj configure], which reads the + # option database and will set init-only options as well as + # ordinary ones. Intended to be called from a constructor. + # + # The actual method is called something else because it does + # forwarding trickery to track the spelling of how it has been + # called. + # + # ------------------------------------------------------------------ + + method Impl {methodName pathName args} { + ::if {[info exists initialised] && $initialised} { + ::return -code error -errorcode {TK DOUBLE_INIT} \ + "this object is already initialised" + } + ::if {[::llength $args] % 2} { + # TODO: generate a more accurate error message + ::set call "my $methodName pathName ?-option value...?" + ::return -code error -errorcode {TCL WRONGARGS} \ + "wrong # args: should be \"$call\"" + } + ::set toSet {} + ::set opts [my ReadableOptions] + ::try { + # Tricky point: we will be writing to read-only options here. + ::foreach opt $opts { + ::set desc [my ] + ::if {[llength $desc] == 1} { + # Skip aliases + ::continue + } + ::lassign $desc nm cls def + ::set val [::option get $pathName $nm $cls $def] + ::if {[catch {my $val}]} { + # If the user forces a bad value via the option DB, + # use our default anyway. It's the best we can do and + # the DB is (by *design*) not entirely under script + # control. + ::set val $def + } + ::dict set toSet $opt $val + } + ::foreach {option value} $args { + ::try { + # Tricky point: $opts includes init-only options + ::set opt [::tcl::prefix match -message "option" \ + $opts $option] + } on error msg { + # Rewrite the error code + ::throw [::list TK LOOKUP OPTION $option] $msg + } + ::dict set toSet $opt [my $value] + } + } on error {msg opt} { + # Strip the error trace + ::dict unset opt -errorinfo + ::dict incr opt -level + ::return -options $opt $msg + } + # Apply the computed state + dict for {opt value} $toSet { + my $value + } + ::set initialised true + } + forward Initialise my Impl Initialise + forward Initialize my Impl Initialize + + # Individual widgets do not support defining their own options. + # This is different from ::oo::configurable's properties. + } + + # ---------------------------------------------------------------------- + # + # tk::ConfigurableStandardImplementations -- + # + # The superclass with user-overridable parts of the configurable system. + # + # Tricky point: namespace path of classes is uncertain; fully qualify + # everything. + # + # ---------------------------------------------------------------------- + + ::oo::class create ConfigurableStandardImplementations { + # ------------------------------------------------------------------ + # + # tk::ConfigurableStandardImplementations -- + # + # How to actually read an option of a given name out of the + # state when using the standard model of storage (the array in + # the instance with the empty name). + # + # ------------------------------------------------------------------ + + method {name} { + ::variable "" + ::return $($name) + } + + # ------------------------------------------------------------------ + # + # tk::ConfigurableStandardImplementations -- + # + # How to actually write an option of a given name to the state + # when using the standard model of storage (the array in the + # instance with the empty name). + # + # ------------------------------------------------------------------ + + method {name value} { + ::variable "" + ::set ($name) $value + } + + # ------------------------------------------------------------------ + # + # tk::ConfigurableStandardImplementations -- + # + # How to make a checkpoint of the state that can be restored if + # the configuration of the object fails. If overridden, the + # companion method should also be + # overridden. The format of checkpoints is undocumented + # formally, but this implementation uses a dictionary. + # + # ------------------------------------------------------------------ + + method {} { + ::variable "" + ::array get "" + } + + # ------------------------------------------------------------------ + # + # tk::ConfigurableStandardImplementations -- + # + # How to restore a checkpoint of the state because the + # configuration of the object has failed. If overridden, the + # companion method should also be + # overridden. The format of checkpoints is undocumented + # formally, but this implementation uses a dictionary. + # + # ------------------------------------------------------------------ + + method {checkpoint} { + ::variable "" + ::array set "" $checkpoint + } + + # ------------------------------------------------------------------ + # + # tk::ConfigurableStandardImplementations PostConfigure -- + # + # Hook for user code to find out when a state change really + # occurred with [$obj configure]. Does nothing by default; + # subclasses may change this. + # + # ------------------------------------------------------------------ + + method PostConfigure {} {} + } + + # ---------------------------------------------------------------------- + # + # tk::configurable -- + # + # The metaclass for making megawidgets (which are always configurable). + # Too bare at this point; intended to grow! + # + # ---------------------------------------------------------------------- + + ::oo::class create configurable { + superclass ::oo::class + + constructor {{definitionScript ""}} { + next { + superclass ::tk::ConfigurableStandardImplementations + mixin ::tk::Configurable + } + next $definitionScript + } + definitionnamespace -class ::tk::OptionDefine + } + + # ---------------------------------------------------------------------- + # + # tk::optiontype -- + # + # The class of types of options. Abstract because concrete subclasses + # define how the validation is done. + # + # Provides two variables to subclasses that they may use: + # * TypeName - the name of the type, cleaned up for display to users + # in error messages. + # * ErrorCode - a list describing the standard error code for problems + # with parsing this type + # + # ---------------------------------------------------------------------- + + ::oo::abstract create optiontype { + private variable def name + variable TypeName ErrorCode + + constructor {default} { + set def $default + set name [namespace tail [self]] + # Ugly hack! Trims *one* leading 'z' from the type name + set TypeName [regsub {^z} $name ""] + set ErrorCode [list TK VALUE [string toupper $TypeName]] + set map [namespace ensemble configure ::tk::OptionType -map] + dict set map $name [self] + namespace ensemble configure ::tk::OptionType -map $map + } + + destructor { + set map [namespace ensemble configure ::tk::OptionType -map] + dict unset map $name + namespace ensemble configure ::tk::OptionType -map $map + } + + # ------------------------------------------------------------------ + # + # tk::optiontype validate -- + # + # How to validate that the sole argument (conventionally called + # 'value') is a member of the type. Throws an error if it is not + # of the type. Also normalizes the value if it is of the type; + # for most types, this is a trivial no-change operation, but for + # some types it may be more significant (e.g., expanding a + # unique prefix with a table-driven type). + # + # ------------------------------------------------------------------ + + method validate {value} { + throw UNIMPLEMENTED "unimplemented method" + } + + # ------------------------------------------------------------------ + # + # tk::optiontype default -- + # + # Produces the default value of the type. The rest of the code + # assumes that this is a constant, so it is recommended to be a + # zero or an empty string (where these are meaningful). + # + # ------------------------------------------------------------------ + + method default {} { + return $def + } + + self { + # -------------------------------------------------------------- + # + # tk::optiontype Create -- + # + # Actual factory method. Wrapper that creates classes of the + # correct implementation type with the right name. + # + # -------------------------------------------------------------- + + method Create {realClass name args} { + # Condition the class name first + set name [namespace current]::[namespace tail $name] + tailcall $realClass create $name {*}$args + } + + # -------------------------------------------------------------- + # + # tk::optiontype createbool -- + # + # Create a option type that is driven by a boolean test. + # + # -------------------------------------------------------------- + + forward createbool my Create ::tk::BoolTestType + + # -------------------------------------------------------------- + # + # tk::optiontype createthrow -- + # + # Create a option type that is driven by an erroring test. + # + # -------------------------------------------------------------- + + forward createthrow my Create ::tk::ThrowTestType + + # -------------------------------------------------------------- + # + # tk::optiontype createtable -- + # + # Create a option type that is driven by a table of valid + # values (effectively an enumeration, Tcl-style). + # + # -------------------------------------------------------------- + + forward createtable my Create ::tk::TableType + } + } + + ::oo::class create BoolTestType { + superclass optiontype + private variable + variable TypeName ErrorCode + + constructor {default test {normalizer {}}} { + next $default + ::oo::objdefine [self] forward Validate {*}$test + if {$normalizer ne ""} { + ::oo::objdefine [self] method Normalize {value} $normalizer + } + } + + method validate {value} { + if {![my Validate $value]} { + return -code error -errorcode $ErrorCode \ + "invalid $TypeName value \"$value\"" + } + try { + return [my Normalize $value] + } on error {msg opt} { + return -code error -errorcode [dict get $opt -errorcode] $msg + } + } + + method Normalize {value} { + return $value + } + } + + ::oo::class create ThrowTestType { + superclass optiontype + variable ErrorCode + + constructor {default test {normalizer {}}} { + next $default + ::oo::objdefine [self] method Validate value $test + if {$normalizer ne ""} { + ::oo::objdefine [self] method Normalize {value} $normalizer + } + } + + method validate {value} { + try { + my Validate $value + } on error {msg} { + return -code error -errorcode $ErrorCode $msg + } + try { + return [my Normalize $value] + } on error {msg opt} { + return -code error -errorcode [dict get $opt -errorcode] $msg + } + } + + method Normalize {value} { + return $value + } + } + + ::oo::class create TableType { + superclass optiontype + + private variable Table Error + variable TypeName ErrorCode + constructor {default table} { + if {$default ni $table} { + # This requires that the default be not an abbreviation + error "default value \"$default\" not in table of licit values" + } + next $default + set Table $table + set Error [list -level 1 -errorcode $ErrorCode] + } + + method validate {value} { + ::tcl::prefix match -message $TypeName -error $Error $Table $value + } + } + + # ---------------------------------------------------------------------- + # + # Install the actual types. + # + # ---------------------------------------------------------------------- + + # Install the types: those with a boolean test + optiontype createbool boolean "false" { + string is boolean -strict + } {lindex {true false} [expr {!$value}]} + optiontype createbool zboolean "" { + string is boolean + } { + if {$value ne ""} { + lindex {true false} [expr {!$value}] + } + } + optiontype createbool integer "0" { + string is entier -strict + } {expr {[string trim $value] + 0}} + optiontype createbool zinteger "" { + string is entier + } { + set value [string trim $value] + expr {$value eq "" ? "" : $value + 0} + } + optiontype createbool float "0.0" { + string is double -strict + } {expr {[string trim $value] + 0.0}} + optiontype createbool zfloat "" { + string is double + } { + set value [string trim $value] + expr {$value eq "" ? "" : $value + 0.0} + } + optiontype createbool list "" { + string is list + } {list {*}$value} + optiontype createbool dict "" { + string is dict + } {dict merge {} $value} + optiontype createbool window "" { + apply {value {expr {$value eq "" || [winfo exists $value]}}} + } + + # Install the types: those with an erroring test + oo::objdefine [optiontype createthrow string {} {}] { + # Special case; everything valid + method validate value {return $value} + } + optiontype createthrow distance "0p" { + winfo fpixels . $value + } + optiontype createthrow image "" { + if {$value ne ""} { + image type $value + } + } + optiontype createthrow color "#000000" { + winfo rgb . $value + } { + lassign [winfo rgb . $value] r g b + format "#%02x%02x%02x" \ + [expr {$r >> 8}] [expr {$g >> 8}] [expr {$b >> 8}] + } + optiontype createthrow zcolor "" { + if {$value ne ""} { + winfo rgb . $value + } + } { + if {$value ne ""} { + lassign [winfo rgb . $value] r g b + format "#%02x%02x%02x" \ + [expr {$r >> 8}] [expr {$g >> 8}] [expr {$b >> 8}] + } + } + optiontype createthrow font "TkDefaultFont" { + # Cheapest property of fonts to read + font metrics $value -fixed + } + optiontype createthrow cursor "" { + if {$value ne ""} { + ::tk::ParseCursor $value + } + } + + # Install the types: those with an element table + optiontype createtable anchor "center" { + n ne e se s sw w nw center + } + optiontype createtable justify "left" { + center left right + } + optiontype createtable relief "flat" { + flat groove raised ridge solid sunken + } +} + +# Local Variables: +# mode: tcl +# c-basic-offset: 4 +# fill-column: 78 +# End: Index: library/tk.tcl ================================================================== --- library/tk.tcl +++ library/tk.tcl @@ -815,10 +815,13 @@ # Run the Ttk themed widget set initialization if {$::ttk::library ne ""} { uplevel \#0 [list source -encoding utf-8 $::ttk::library/ttk.tcl] } + +# Add in our classes +uplevel \#0 [list source [file join [file dirname [info script]] oocfg.tcl]] # Local Variables: # mode: tcl # fill-column: 78 # End: Index: tests/cursor.test ================================================================== --- tests/cursor.test +++ tests/cursor.test @@ -45,11 +45,28 @@ } set wincur(dir) [makeDirectory {dir with spaces}] set wincur(file) [makeFile $wincur(data_binary) "test file.cur" $wincur(dir)] } - +# For ensuring that we don't leak memory +testConstraint memory [llength [info commands memory]] +if {[testConstraint memory]} { + proc getbytes {} { + set lines [split [memory info] \n] + return [lindex $lines 3 3] + } + proc leaktest {script {iterations 3}} { + set end [getbytes] + for {set i 0} {$i < $iterations} {incr i} { + uplevel 1 $script + set tmp $end + set end [getbytes] + } + return [expr {$end - $tmp}] + } +} + test cursor-1.1 {Tk_AllocCursorFromObj - converting internal reps} -constraints { testcursor } -body { set x watch lindex $x 0 @@ -837,10 +854,57 @@ .b configure -cursor wait } -cleanup { destroy .b } -result {} +set badcursor {gorp gorp gorp gorp gorp} +test cursor-8.1 {basic cursor parsing} { + tk::ParseCursor watch +} {} +test cursor-8.2 {basic cursor parsing} -returnCodes error -body { + tk::ParseCursor $badcursor +} -result {bad cursor spec "gorp gorp gorp gorp gorp"} +test cursor-8.3 {basic cursor parsing} -returnCodes error -body { + tk::ParseCursor {} +} -result {bad cursor spec ""} +test cursor-8.4 {cursor parsing: memory cleanliness} memory { + leaktest { + tk::ParseCursor watch + } +} 0 +test cursor-8.5 {cursor parsing: memory cleanliness} memory { + leaktest { + catch { + tk::ParseCursor $badcursor + } + } +} 0 +test cursor-8.6 {evil poke-under-the-covers of cursor parsing} -setup { + set cursor [join {w a t c h} ""] +} -body { + tk::ParseCursor $cursor + tcl::unsupported::representation $cursor +} -match glob -result {value is a cursor *} +test cursor-8.7 {evil poke-under-the-covers of cursor parsing} -setup { + unset -nocomplain a b + set cursor [join {a r r o w} ""] + frame .cursortest -cursor $cursor + pack .cursortest + update +} -body { + set a [tk::ParseCursor $cursor; tcl::unsupported::representation $cursor] + set b [tk::ParseCursor $cursor; tcl::unsupported::representation $cursor] + list $a [lindex {!= ==} [string equal $a $b]] $b +} -match glob -cleanup { + unset -nocomplain cursor + destroy .cursortest +} -result {{value is a cursor *} == {value is a cursor *}} + # ------------------------------------------------------------------------- # cleanup cleanupTests return + +# Local Variables: +# mode: tcl +# End: ADDED tests/oocfg.test Index: tests/oocfg.test ================================================================== --- /dev/null +++ tests/oocfg.test @@ -0,0 +1,1342 @@ +# This file is a Tcl script to test entry widgets in Tk. It is +# organized in the standard fashion for Tcl tests. +# +# Copyright (c) 1994 The Regents of the University of California. +# Copyright (c) 1994-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# All rights reserved. + +package require tcltest 2.2 +eval tcltest::configure $argv +tcltest::loadTestedCommands +namespace import -force tcltest::test + +deleteWindows + +# A simple superclass to handle calling Initialise and cleaning up +oo::class create cfgsupport { + private variable window + constructor {w args} { + set window [frame $w] + my Initialise $w {*}$args + } + destructor { + destroy $window + } + + self method clean {} { + foreach c [info class subclasses [self]] { + catch {$c destroy} + } + } +} + +# A simpler version without even initialisation; this is a plain class. Note +# that cfgsupport doesn't inherit from this because the clean method is too +# simple-minded. +oo::class create base { + private variable window + constructor {w args} { + set window [frame $w] + } + destructor { + destroy $window + } + + self method clean {} { + foreach c [info class subclasses [self]] { + catch {$c destroy} + } + } +} + +test oocfg-1.1 {tk::configurable: basic test} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo + } + set gorp [Gorp new .gorp -foo bar] + list [$gorp configure] [$gorp configure -foo] [$gorp configure -foo grill] \ + [$gorp cget -foo] +} -cleanup { + cfgsupport clean +} -result {{{-foo foo Foo {} bar}} {-foo foo Foo {} bar} {} grill} +test oocfg-1.2 {tk::configurable: basic test with default} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo -default 135 + } + set gorp [Gorp new .gorp -foo bar] + list [$gorp configure] [$gorp configure -foo] [$gorp configure -foo grill] \ + [$gorp cget -foo] +} -cleanup { + cfgsupport clean +} -result {{{-foo foo Foo 135 bar}} {-foo foo Foo 135 bar} {} grill} +test oocfg-1.3 {tk::configurable: basic test with typing} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo -type integer + } + set gorp [Gorp new .gorp -foo 789] + list [$gorp configure] [$gorp configure -foo] [$gorp configure -foo 153] \ + [$gorp cget -foo] [catch {$gorp configure -foo bar} msg] $msg +} -cleanup { + cfgsupport clean +} -result {{{-foo foo Foo 0 789}} {-foo foo Foo 0 789} {} 153 1 {invalid integer value "bar"}} +test oocfg-1.4 {tk::configurable: basic test with alias} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo -type integer -default 135 + option bar -alias foo + } + set gorp [Gorp new .gorp -bar 789] + list [$gorp configure] [$gorp configure -bar] [$gorp configure -bar 153] \ + [$gorp cget -foo] [$gorp cget -bar] \ + [catch {$gorp configure -bar grill} msg] $msg +} -cleanup { + cfgsupport clean +} -result {{{-bar -foo} {-foo foo Foo 135 789}} {-bar -foo} {} 153 153 1 {invalid integer value "grill"}} +test oocfg-1.5 {tk::configurable: basic test with option DB} -setup { + option clear +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo -default bar + } + option add *gorp.foo ok + set gorp [Gorp new .gorp] + $gorp configure +} -cleanup { + option clear + cfgsupport clean +} -result {{-foo foo Foo bar ok}} +test oocfg-1.6 {tk::configurable: basic test with option DB} -setup { + option clear +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo -default bar + } + option add *gorp.Foo ok + set gorp [Gorp new .gorp] + $gorp configure +} -cleanup { + option clear + cfgsupport clean +} -result {{-foo foo Foo bar ok}} +test oocfg-1.7 {tk::configurable: basic test with option DB} -setup { + option clear +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo -default bar + } + option add *gorp.foo xyz + option add *gorp.Foo zyx + set gorp [Gorp new .gorp] + $gorp configure +} -cleanup { + option clear + cfgsupport clean +} -result {{-foo foo Foo bar zyx}} +test oocfg-1.8 {tk::configurable: basic test with option DB} -setup { + option clear +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo -name foobar -class FooBar -default ok + } + option add *gorp.foo bad + set gorp [Gorp new .gorp] + $gorp configure +} -cleanup { + option clear + cfgsupport clean +} -result {{-foo foobar FooBar ok ok}} +test oocfg-1.9 {tk::configurable: basic test with option DB} -setup { + option clear +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo -name foobar -class FooBar -default ok + } + option add *gorp.foo bad + option add *FooBar great + set gorp [Gorp new .gorp] + $gorp configure +} -cleanup { + option clear + cfgsupport clean +} -result {{-foo foobar FooBar ok great}} +test oocfg-1.10 {tk::configurable: basic test with option DB} -setup { + option clear +} -body { + tk::configurable create Gorp { + superclass cfgsupport + # Values from option DB are subject to validation, but failure just + # triggers using the default, not an error. + option foo -name foo -default 123 -type integer + } + option add *gorp.foo bad + set gorp [Gorp new .gorp] + $gorp configure +} -cleanup { + option clear + cfgsupport clean +} -result {{-foo foo Foo 123 123}} +test oocfg-1.11 {tk::configurable: basic test with inheritance} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo + } + tk::configurable create Gorp2 { + superclass Gorp + option bar + } + set gorp [Gorp2 new .gorp -foo 1 -bar 2] + $gorp configure +} -cleanup { + cfgsupport clean +} -result {{-bar bar Bar {} 2} {-foo foo Foo {} 1}} +test oocfg-1.12 {tk::configurable: basic test with inheritance} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo -default abc + } + tk::configurable create Gorp2 { + superclass Gorp + option foo -default xyz + } + set gorp [Gorp2 new .gorp] + $gorp configure +} -cleanup { + cfgsupport clean +} -result {{-foo foo Foo xyz xyz}} + +test oocfg-2.1 {tk::configurable: option cfg abbreviation} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo -def ok + option bar -al foo + } + [Gorp new .gorp] configure +} -cleanup { + cfgsupport clean +} -result {{-bar -foo} {-foo foo Foo ok ok}} +test oocfg-2.2 {tk::configurable: option cfg abbreviation} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo -def ok + option bar -al -foo + } + [Gorp new .gorp] configure +} -cleanup { + cfgsupport clean +} -result {{-bar -foo} {-foo foo Foo ok ok}} +test oocfg-2.3 {tk::configurable: option cfg abbreviation} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo -def ok -n john -c Smith + } + [Gorp new .gorp] configure +} -cleanup { + cfgsupport clean +} -result {{-foo john Smith ok ok}} +test oocfg-2.4 {tk::configurable: option cfg abbreviation and case} -body { + tk::configurable create Gorp { + superclass cfgsupport + option FOO -ty str + } + [Gorp new .gorp] configure +} -cleanup { + cfgsupport clean +} -result {{-FOO foo Foo {} {}}} +test oocfg-2.5 {tk::configurable: option cfg abbreviation} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo -ty just -de r + } + [Gorp new .gorp] configure +} -cleanup { + cfgsupport clean +} -result {{-foo foo Foo right right}} + +test oocfg-3.1 {tk::configurable: option errors} -returnCodes error -body { + tk::configurable create Gorp { + option foo -gorp + } +} -result {wrong # args: should be "option name ?-option value ...?"} +test oocfg-3.2 {tk::configurable: option errors} -returnCodes error -body { + tk::configurable create Gorp { + option foo -gorp blat + } +} -result {bad option "-gorp": must be -alias, -class, -default, -initonly, -name, or -type} +test oocfg-3.3 {tk::configurable: option errors} -returnCodes error -body { + tk::configurable create Gorp { + option foo -type gorp + } +} -match glob -result {unknown or ambiguous subcommand "gorp": must be *} +test oocfg-3.3a {tk::configurable: option errors} -returnCodes error -body { + tk::configurable create Gorp { + option foo -type gorp + } +} -match glob -result {*: must be anchor, boolean, color, cursor, dict, distance, float, font, image, integer, justify, list, relief, string, window, zboolean, zcolor, zfloat, or zinteger} +test oocfg-3.3b {tk::configurable: option errors} -setup { + unset -nocomplain ot +} -body { + set ot [tk::optiontype createbool gorp gorpgorp {string length}] + tk::configurable create Gorp { + option foo -type gorp -default "" + } +} -returnCodes error -cleanup { + if {[info exists ot]} { + $ot destroy + unset ot + } +} -result {invalid gorp value ""} +test oocfg-3.4 {tk::configurable: option errors} -returnCodes error -body { + tk::configurable create Gorp { + option foo -type integer -default abc + } +} -result {invalid integer value "abc"} +test oocfg-3.5 {tk::configurable: option errors} -returnCodes error -body { + tk::configurable create Gorp { + option foo -default abc -type integer + } +} -result {invalid integer value "abc"} +test oocfg-3.6 {tk::configurable: option errors} -returnCodes error -body { + tk::configurable create Gorp { + option @bad + } +} -result {bad option name "@bad": must be alphanumeric starting with a letter} +test oocfg-3.7 {tk::configurable: option errors} -returnCodes error -body { + tk::configurable create Gorp { + option foo -name Abc + } +} -result {-name must be alphanumeric with a leading lower-case letter} +test oocfg-3.8 {tk::configurable: option errors} -returnCodes error -body { + tk::configurable create Gorp { + option foo -class abc + } +} -result {-class must be alphanumeric with a leading capital letter} +test oocfg-3.9 {tk::configurable: option errors} -returnCodes error -body { + tk::configurable create Gorp { + option foo -alias foo + } +} -result {no such option "-foo"} +test oocfg-3.10 {tk::configurable: option errors} -returnCodes error -body { + tk::configurable create Gorp { + option foo + option bar -type string -alias foo + } +} -result {-alias may only ever be used on its own} +test oocfg-3.11 {tk::configurable: option errors} -returnCodes error -body { + tk::configurable create Gorp { + option foo -init gorp + } +} -result {invalid boolean value "gorp"} +test oocfg-3.12 {tk::configurable: option errors} -returnCodes error -body { + tk::configurable create Gorp { + option foo -init 1 + option bar -alias foo + } +} -result {may not alias init-only option "-foo"} +test oocfg-3.13 {tk::configurable: option errors (cross class)} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo -init 1 + } + tk::configurable create Gorp2 { + superclass Gorp + option bar -alias foo + } +} -returnCodes error -cleanup { + cfgsupport clean +} -result {may not alias init-only option "-foo"} + +test oocfg-4.1 {tk::configurable: configure behaviour: option sorting} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foe -default 1 -name alpha -class Jack + option fie -default 2 -name beta -class Jack + option fum -default 3 -name gamma -class Beanstalk + option fee -default 4 -name delta -class Beanstalk + } + set gorp [Gorp new .gorp] + $gorp configure +} -cleanup { + cfgsupport clean +} -result {{-fee delta Beanstalk 4 4} {-fie beta Jack 2 2} {-foe alpha Jack 1 1} {-fum gamma Beanstalk 3 3}} +test oocfg-4.2 {tk::configurable: configure behaviour: ambiguity} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foe + option fie + option fum + option fee + } + set gorp [Gorp new .gorp] + $gorp configure -f +} -returnCodes error -cleanup { + cfgsupport clean +} -result {ambiguous option "-f": must be -fee, -fie, -foe, or -fum} +test oocfg-4.3 {tk::configurable: configure behaviour: inheritance assembly} -body { + tk::configurable create GorpFoe { + superclass cfgsupport + option foe + } + tk::configurable create GorpFie { + superclass cfgsupport + option fie + } + tk::configurable create GorpFum { + superclass cfgsupport + option fum + } + tk::configurable create GorpFee { + superclass cfgsupport + option fee + } + tk::configurable create Gorp { + superclass GorpFum GorpFee + mixin GorpFoe + } + set gorp [Gorp new .gorp] + oo::objdefine $gorp mixin GorpFie + $gorp configure -f +} -returnCodes error -cleanup { + cfgsupport clean +} -result {ambiguous option "-f": must be -fee, -fie, -foe, or -fum} +test oocfg-4.4 {tk::configurable: configure behaviour: no opts} -body { + tk::configurable create Gorp { + superclass cfgsupport + } + [Gorp new .gorp] configure +} -cleanup { + cfgsupport clean +} -result {} +test oocfg-4.5 {tk::configurable: configure behaviour: no opts} -body { + tk::configurable create Gorp { + superclass cfgsupport + } + [Gorp new .gorp] configure -foo +} -returnCodes error -cleanup { + cfgsupport clean +} -result {bad option "-foo": no valid options} +test oocfg-4.6 {tk::configurable: configure behaviour: no opts} -body { + tk::configurable create Gorp { + superclass cfgsupport + } + [Gorp new .gorp] configure -foo bar +} -returnCodes error -cleanup { + cfgsupport clean +} -result {bad option "-foo": no valid options} +test oocfg-4.7 {tk::configurable: configure behaviour: name prefixes} -setup { + unset -nocomplain result msg +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option verylongname -type int + } + set gorp [Gorp new .gorp -v 1] + lappend result [$gorp configure] [$gorp configure -v] + $gorp configure -v 2 + lappend result [$gorp cget -v] + oo::define Gorp option variation + lappend result :=:=: [catch {$gorp cget -v} msg] $msg +} -cleanup { + cfgsupport clean +} -result {{{-verylongname verylongname Verylongname 0 1}} {-verylongname verylongname Verylongname 0 1} 2 :=:=: 1 {ambiguous option "-v": must be -variation or -verylongname}} +test oocfg-4.8 {tk::configurable: configure behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a + } + catch { + set gorp [Gorp create gorp .gorp] + $gorp configure -a a -a + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{wrong # args: should be "::gorp configure ?-option value ...?"} {TCL WRONGARGS} {wrong # args: should be "::gorp configure ?-option value ...?" + while executing +"$gorp configure -a a -a"}} +test oocfg-4.9 {tk::configurable: configure behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a + } + catch { + set gorp [Gorp create gorp .gorp] + $gorp configure -b + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{bad option "-b": must be -a} {TK LOOKUP OPTION -b} {bad option "-b": must be -a + while executing +"$gorp configure -b"}} +test oocfg-4.10 {tk::configurable: configure behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a + } + catch { + set gorp [Gorp create gorp .gorp] + $gorp configure -b a + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{bad option "-b": must be -a} {TK LOOKUP OPTION -b} {bad option "-b": must be -a + while executing +"$gorp configure -b a"}} +test oocfg-4.11 {tk::configurable: configure behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a -type integer + } + catch { + set gorp [Gorp create gorp .gorp] + $gorp configure -a gorp + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{invalid integer value "gorp"} {TK VALUE INTEGER} {invalid integer value "gorp" + while executing +"$gorp configure -a gorp"}} +test oocfg-4.12 {tk::configurable: configure behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a -type distance + } + catch { + set gorp [Gorp create gorp .gorp] + $gorp configure -a gorp + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{bad screen distance "gorp"} {TK VALUE DISTANCE} {bad screen distance "gorp" + while executing +"$gorp configure -a gorp"}} +test oocfg-4.13 {tk::configurable: configure behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a -type color + } + catch { + set gorp [Gorp create gorp .gorp] + $gorp configure -a @@@gorp@@@ + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{unknown color name "@@@gorp@@@"} {TK VALUE COLOR} {unknown color name "@@@gorp@@@" + while executing +"$gorp configure -a @@@gorp@@@"}} +test oocfg-4.14 {tk::configurable: configure behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a -type font + } + catch { + set gorp [Gorp create gorp .gorp] + # Invalid font names are weird; font parsing is weird + $gorp configure -a "gorp {}gorp" + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{font "gorp {}gorp" doesn't exist} {TK VALUE FONT} {font "gorp {}gorp" doesn't exist + while executing +"$gorp configure -a "gorp {}gorp""}} +test oocfg-4.15 {tk::configurable: configure behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a -type image + } + catch { + set gorp [Gorp create gorp .gorp] + $gorp configure -a @@@gorp@@@ + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{image "@@@gorp@@@" doesn't exist} {TK VALUE IMAGE} {image "@@@gorp@@@" doesn't exist + while executing +"$gorp configure -a @@@gorp@@@"}} +test oocfg-4.16 {tk::configurable: configure behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a -type justify + } + catch { + set gorp [Gorp create gorp .gorp] + $gorp configure -a gorp + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{bad justify "gorp": must be center, left, or right} {TK VALUE JUSTIFY} {bad justify "gorp": must be center, left, or right + while executing +"$gorp configure -a gorp"}} + +test oocfg-5.1 {tk::configurable: Initialise behaviour: option sorting} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foe -default 1 -name alpha -class Jack + option fie -default 2 -name beta -class Jack + option fum -default 3 -name gamma -class Beanstalk + option fee -default 4 -name delta -class Beanstalk + } + Gorp new .gorp -gorp +} -returnCodes error -cleanup { + cfgsupport clean +} -result {wrong # args: should be "my Initialise pathName ?-option value...?"} +test oocfg-5.2 {tk::configurable: Initialise behaviour: ambiguity} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foe + option fie + option fum + option fee + } + Gorp new .gorp -f gorp +} -returnCodes error -cleanup { + cfgsupport clean +} -result {ambiguous option "-f": must be -fee, -fie, -foe, or -fum} +test oocfg-5.3 {tk::configurable: Initialise behaviour: inheritance assembly} -body { + tk::configurable create GorpFoe { + superclass cfgsupport + option foe + } + tk::configurable create GorpFie { + superclass cfgsupport + option fie + } + tk::configurable create GorpFum { + superclass cfgsupport + option fum + } + tk::configurable create GorpFee { + superclass cfgsupport + option fee + } + tk::configurable create Gorp { + superclass GorpFum GorpFee + mixin GorpFoe GorpFie + } + [Gorp new .gorp -fee 1 -fie 2 -foe 3 -fum 4] configure +} -cleanup { + cfgsupport clean +} -result {{-fee fee Fee {} 1} {-fie fie Fie {} 2} {-foe foe Foe {} 3} {-fum fum Fum {} 4}} +test oocfg-5.4 {tk::configurable: Initialise behaviour: no opts} -body { + tk::configurable create Gorp { + superclass cfgsupport + } + Gorp create ::gorp .gorp +} -cleanup { + cfgsupport clean +} -result ::gorp +test oocfg-5.5 {tk::configurable: Initialise behaviour: no opts} -body { + tk::configurable create Gorp { + superclass cfgsupport + } + Gorp new .gorp -foo +} -returnCodes error -cleanup { + cfgsupport clean +} -result {wrong # args: should be "my Initialise pathName ?-option value...?"} +test oocfg-5.6 {tk::configurable: Initialise behaviour: no opts} -body { + tk::configurable create Gorp { + superclass cfgsupport + } + Gorp new .gorp -foo bar +} -returnCodes error -cleanup { + cfgsupport clean +} -result {bad option "-foo": no valid options} +test oocfg-5.7 {tk::configurable: Initialise behaviour: name prefixes} -setup { + unset -nocomplain result msg +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option verylongname -type int + } + set gorp [Gorp new .gorp -v 1] + lappend result [$gorp configure] + oo::define Gorp option variation + lappend result :=:=: [catch {Gorp new .gorp2 -v 2} msg] $msg +} -cleanup { + cfgsupport clean +} -result {{{-verylongname verylongname Verylongname 0 1}} :=:=: 1 {ambiguous option "-v": must be -variation or -verylongname}} +test oocfg-5.8 {tk::configurable: Initialise behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a + } + catch { + Gorp create gorp .gorp -a a -a + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{wrong # args: should be "my Initialise pathName ?-option value...?"} {TCL WRONGARGS} {wrong # args: should be "my Initialise pathName ?-option value...?" + while executing +"my Initialise $w {*}$args" + (class "::cfgsupport" constructor line 3) + invoked from within +"Gorp create gorp .gorp -a a -a"}} +test oocfg-5.9 {tk::configurable: Initialise behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a + } + catch { + Gorp create gorp .gorp -b gorp + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{bad option "-b": must be -a} {TK LOOKUP OPTION -b} {bad option "-b": must be -a + while executing +"my Initialise $w {*}$args" + (class "::cfgsupport" constructor line 3) + invoked from within +"Gorp create gorp .gorp -b gorp"}} +test oocfg-5.10 {tk::configurable: Initialise behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a + } + catch { + Gorp create gorp .gorp -b a + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{bad option "-b": must be -a} {TK LOOKUP OPTION -b} {bad option "-b": must be -a + while executing +"my Initialise $w {*}$args" + (class "::cfgsupport" constructor line 3) + invoked from within +"Gorp create gorp .gorp -b a"}} +test oocfg-5.11 {tk::configurable: Initialise behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a -type integer + } + catch { + Gorp create gorp .gorp -a gorp + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{invalid integer value "gorp"} {TK VALUE INTEGER} {invalid integer value "gorp" + while executing +"my Initialise $w {*}$args" + (class "::cfgsupport" constructor line 3) + invoked from within +"Gorp create gorp .gorp -a gorp"}} +test oocfg-5.12 {tk::configurable: Initialise behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a -type distance + } + catch { + Gorp create gorp .gorp -a gorp + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{bad screen distance "gorp"} {TK VALUE DISTANCE} {bad screen distance "gorp" + while executing +"my Initialise $w {*}$args" + (class "::cfgsupport" constructor line 3) + invoked from within +"Gorp create gorp .gorp -a gorp"}} +test oocfg-5.13 {tk::configurable: Initialise behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a -type color + } + catch { + Gorp create gorp .gorp -a @@@gorp@@@ + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{unknown color name "@@@gorp@@@"} {TK VALUE COLOR} {unknown color name "@@@gorp@@@" + while executing +"my Initialise $w {*}$args" + (class "::cfgsupport" constructor line 3) + invoked from within +"Gorp create gorp .gorp -a @@@gorp@@@"}} +test oocfg-5.14 {tk::configurable: Initialise behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a -type font + } + catch { + # Invalid font names are weird; font parsing is weird + Gorp create gorp .gorp -a "gorp {}gorp" + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{font "gorp {}gorp" doesn't exist} {TK VALUE FONT} {font "gorp {}gorp" doesn't exist + while executing +"my Initialise $w {*}$args" + (class "::cfgsupport" constructor line 3) + invoked from within +"Gorp create gorp .gorp -a "gorp {}gorp""}} +test oocfg-5.15 {tk::configurable: Initialise behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a -type image + } + catch { + Gorp create gorp .gorp -a @@@gorp@@@ + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{image "@@@gorp@@@" doesn't exist} {TK VALUE IMAGE} {image "@@@gorp@@@" doesn't exist + while executing +"my Initialise $w {*}$args" + (class "::cfgsupport" constructor line 3) + invoked from within +"Gorp create gorp .gorp -a @@@gorp@@@"}} +test oocfg-5.16 {tk::configurable: Initialise behaviour: errors} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option a -type justify + } + catch { + Gorp create gorp .gorp -a gorp + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + cfgsupport clean +} -result {{bad justify "gorp": must be center, left, or right} {TK VALUE JUSTIFY} {bad justify "gorp": must be center, left, or right + while executing +"my Initialise $w {*}$args" + (class "::cfgsupport" constructor line 3) + invoked from within +"Gorp create gorp .gorp -a gorp"}} + +test oocfg-6.1 {tk::configurable: Initialise: alt spelling} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass base + constructor {w args} { + next $w + my Initialize $w {*}$args + } + option a + } + set gorp [Gorp create gorp .gorp -a gorp] + list $gorp [$gorp cget -a] +} -cleanup { + base clean +} -result {::gorp gorp} +test oocfg-6.2 {tk::configurable: Initialise: alt spelling} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass base + constructor {w args} { + next $w + my Initialize $w {*}$args + } + option a + } + catch { + Gorp create gorp .gorp -a gorp -a + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + base clean +} -result {{wrong # args: should be "my Initialize pathName ?-option value...?"} {TCL WRONGARGS} {wrong # args: should be "my Initialize pathName ?-option value...?" + while executing +"my Initialize $w {*}$args" + (class "::Gorp" constructor line 3) + invoked from within +"Gorp create gorp .gorp -a gorp -a"}} +test oocfg-6.3 {tk::configurable: Initialise: double call} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass base + constructor {w args} { + next $w + my Initialise $w {*}$args + my Initialize $w {*}$args + } + option a + } + catch { + Gorp create gorp .gorp -a gorp + } msg opt + list $msg [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + base clean +} -result {{this object is already initialised} {TK DOUBLE_INIT} {this object is already initialised + while executing +"my Initialize $w {*}$args" + (class "::Gorp" constructor line 4) + invoked from within +"Gorp create gorp .gorp -a gorp"}} +test oocfg-6.4 {tk::configurable: Initialise: smartass} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass base + constructor {w args} { + # NOT a recommended way of working; rude towards subclasses and + # uses not-well-documented result of superclass constructor. + tailcall my Initialise [next $w] {*}$args + } + option a + } + catch { + Gorp create gorp .gorp -a gorp -a + } msg opt + list $msg [winfo exists .gorp] \ + [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + base clean +} -result {{wrong # args: should be "my Initialise pathName ?-option value...?"} 0 {TCL WRONGARGS} {wrong # args: should be "my Initialise pathName ?-option value...?" + while executing +"my Initialise .gorp -a gorp -a" + invoked from within +"Gorp create gorp .gorp -a gorp -a"}} + +test oocfg-7.1 {tk::configurable: init-only params} -setup { + unset -nocomplain msg opt +} -body { + tk::configurable create Gorp { + superclass base + constructor {w args} { + next $w + my Initialise $w {*}$args + } + option a -initonly 1 + } + set gorp [Gorp create foobar .gorp -a blarg] + list $gorp [$gorp configure] [$gorp cget -a] \ + [catch {$gorp configure -a foo} msg opt] $msg \ + [dict get $opt -errorcode] [dict get $opt -errorinfo] +} -cleanup { + base clean +} -result {::foobar {{-a a A {} blarg}} blarg 1 {read only option: -a} {TK LOOKUP OPTION -a} {read only option: -a + while executing +"$gorp configure -a foo"}} + +test oocfg-8.1 {tk::configurable: overridden getter} -setup { + unset -nocomplain ::reads + set ::reads {} + proc recordcall {} "lappend ::reads \[info level [expr [info level] + 1]\]" +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo + method {} { + recordcall + tailcall my foo + } + } + Gorp create gorp .gorp -foo 1 + list $reads [gorp cget -foo] $reads [gorp configure -foo] $reads \ + [gorp configure] $reads [gorp configure -foo 2] $reads +} -cleanup { + cfgsupport clean + rename recordcall {} +} -result {{} 1 {{gorp cget -foo}} {-foo foo Foo {} 1} {{gorp cget -foo} {gorp configure -foo}} {{-foo foo Foo {} 1}} {{gorp cget -foo} {gorp configure -foo} {gorp configure}} {} {{gorp cget -foo} {gorp configure -foo} {gorp configure}}} +test oocfg-8.2 {tk::configurable: overridden getter} -setup { + unset -nocomplain ::reads + set ::reads {} + proc recordcall {} "lappend ::reads \[info level [expr [info level] + 1]\]" +} -body { + tk::configurable create Gorp { + superclass cfgsupport + method {} { + recordcall + tailcall my foo + } + option foo + } + Gorp create gorp .gorp -foo 1 + list $reads [gorp cget -foo] $reads [gorp configure -foo] $reads \ + [gorp configure] $reads [gorp configure -foo 2] $reads +} -cleanup { + cfgsupport clean + rename recordcall {} +} -result {{} 1 {{gorp cget -foo}} {-foo foo Foo {} 1} {{gorp cget -foo} {gorp configure -foo}} {{-foo foo Foo {} 1}} {{gorp cget -foo} {gorp configure -foo} {gorp configure}} {} {{gorp cget -foo} {gorp configure -foo} {gorp configure}}} +test oocfg-8.3 {tk::configurable: overridden setter} -setup { + unset -nocomplain ::writes + set ::writes {} + proc recordcall {} "lappend ::writes \[info level [expr [info level] + 1]\]" +} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo + method value { + recordcall + tailcall my foo $value + } + } + Gorp create gorp .gorp -foo 1 + list $writes [gorp cget -foo] $writes [gorp configure -foo] $writes \ + [gorp configure] $writes [gorp configure -foo 2] $writes +} -cleanup { + cfgsupport clean + rename recordcall {} +} -result {{{Gorp create gorp .gorp -foo 1}} 1 {{Gorp create gorp .gorp -foo 1}} {-foo foo Foo {} 1} {{Gorp create gorp .gorp -foo 1}} {{-foo foo Foo {} 1}} {{Gorp create gorp .gorp -foo 1}} {} {{Gorp create gorp .gorp -foo 1} {gorp configure -foo 2}}} +test oocfg-8.4 {tk::configurable: overridden setter} -setup { + unset -nocomplain ::writes + set ::writes {} + proc recordcall {} "lappend ::writes \[info level [expr [info level] + 1]\]" +} -body { + tk::configurable create Gorp { + superclass cfgsupport + method value { + recordcall + tailcall my foo $value + } + option foo + } + Gorp create gorp .gorp -foo 1 + list $writes [gorp cget -foo] $writes [gorp configure -foo] $writes \ + [gorp configure] $writes [gorp configure -foo 2] $writes +} -cleanup { + cfgsupport clean + rename recordcall {} +} -result {{{Gorp create gorp .gorp -foo 1}} 1 {{Gorp create gorp .gorp -foo 1}} {-foo foo Foo {} 1} {{Gorp create gorp .gorp -foo 1}} {{-foo foo Foo {} 1}} {{Gorp create gorp .gorp -foo 1}} {} {{Gorp create gorp .gorp -foo 1} {gorp configure -foo 2}}} + +test oocfg-9.1 {tk::configurable: checkpointing} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo -type integer + option bar -type integer + method {} { + variable "" + # Not actually safe in general because of aliases, but there's + # none of them in this test + join [lmap p [info object properties [self] -all] { + set ([string trimleft $p -]) + }] : + } + method state { + variable "" + foreach p [info object properties [self] -all] v [split $state :] { + set ([string trimleft $p -]) $v + } + } + export + } + Gorp create gorp .gorp + # Note that this checks that we can restore an illegal state. + # User code is strongly recommended to not do this! + list [info object properties gorp -all] [gorp ] \ + [catch {gorp configure -foo 1 -bar x}] [gorp configure] \ + [gorp configure -foo 1 -bar 2] [gorp ] \ + [gorp pqr:xyz] [gorp configure] +} -cleanup { + cfgsupport clean +} -result {{-bar -foo} 0:0 1 {{-bar bar Bar 0 0} {-foo foo Foo 0 0}} {} 2:1 {} {{-bar bar Bar 0 pqr} {-foo foo Foo 0 xyz}}} +test oocfg-9.2 {tk::configurable: checkpointing} -body { + tk::configurable create Gorp { + superclass cfgsupport + option foo -type integer + option bar -type integer + export + } + Gorp create gorp .gorp + # Note that this checks that we can restore an illegal state. + # User code is strongly recommended to not do this! + list [info object properties gorp -all] [gorp ] \ + [catch {gorp configure -foo 1 -bar x}] [gorp configure] \ + [gorp configure -foo 1 -bar 2] [gorp ] \ + [gorp {bar pqr foo xyz}] [gorp configure] +} -cleanup { + cfgsupport clean +} -result {{-bar -foo} {foo 0 bar 0} 1 {{-bar bar Bar 0 0} {-foo foo Foo 0 0}} {} {foo 1 bar 2} {} {{-bar bar Bar 0 pqr} {-foo foo Foo 0 xyz}}} + +test oocfg-10.1 {standard type list} -returnCodes error -body { + tk::OptionType ? +} -result {unknown or ambiguous subcommand "?": must be anchor, boolean, color, cursor, dict, distance, float, font, image, integer, justify, list, relief, string, window, zboolean, zcolor, zfloat, or zinteger} +test oocfg-10.2 {types: registration and deregistration} -match glob -body { + catch {tk::OptionType ?} msg1 + set gorp [tk::optiontype createbool gorp "abc" {apply {x { + expr {[string length $x] % 2} + }}}] + catch {tk::OptionType ?} msg2 + $gorp destroy + catch {tk::OptionType ?} msg3 + list $msg1 | $msg2 | $msg3 +} -result {{*font, image*} | {*font, gorp, image*} | {*font, image*}} + +test oocfg-11.1 {types: anchor} { + tk::OptionType anchor default +} center +test oocfg-11.2 {types: anchor} { + tk::OptionType anchor validate c +} center +test oocfg-11.3 {types: anchor} -returnCodes error -body { + tk::OptionType anchor validate gorp +} -result {bad anchor "gorp": must be n, ne, e, se, s, sw, w, nw, or center} + +test oocfg-12.1 {types: boolean} { + tk::OptionType boolean default +} false +test oocfg-12.2 {types: boolean} { + tk::OptionType boolean validate 0 +} false +test oocfg-12.3 {types: boolean} -returnCodes error -body { + tk::OptionType boolean validate gorp +} -result {invalid boolean value "gorp"} + +test oocfg-13.1 {types: color} { + tk::OptionType color default +} "#000000" +test oocfg-13.2 {types: color} { + tk::OptionType color validate green +} "#008000" +test oocfg-13.3 {types: color} -returnCodes error -body { + tk::OptionType color validate gorp +} -result {unknown color name "gorp"} + +test oocfg-14.1 {types: cursor} { + tk::OptionType cursor default +} {} +test oocfg-14.2 {types: cursor} { + tk::OptionType cursor validate watch +} watch +test oocfg-14.3 {types: cursor} { + tk::OptionType cursor validate "" +} "" +test oocfg-14.4 {types: cursor} -returnCodes error -body { + tk::OptionType cursor validate {gorp gorp gorp gorp gorp} +} -result {bad cursor spec "gorp gorp gorp gorp gorp"} + +test oocfg-15.1 {types: dict} { + tk::OptionType dict default +} {} +test oocfg-15.2 {types: color} { + tk::OptionType dict validate { a b a c x y x z } +} {a c x z} +test oocfg-15.3 {types: color} -returnCodes error -body { + tk::OptionType dict validate gorp +} -result {invalid dict value "gorp"} + +test oocfg-16.1 {types: distance} { + tk::OptionType distance default +} 0p +test oocfg-16.2 {types: distance} { + tk::OptionType distance validate 123p +} 123p +test oocfg-16.3 {types: distance} -returnCodes error -body { + tk::OptionType distance validate gorp +} -result {bad screen distance "gorp"} + +test oocfg-17.1 {types: float} { + tk::OptionType float default +} 0.0 +test oocfg-17.2 {types: float} { + tk::OptionType float validate 1.2e3 +} 1200.0 +test oocfg-17.3 {types: float} -returnCodes error -body { + tk::OptionType float validate gorp +} -result {invalid float value "gorp"} + +test oocfg-18.1 {types: font} { + tk::OptionType font default +} TkDefaultFont +test oocfg-18.2 {types: font} { + tk::OptionType font validate fixed +} fixed +test oocfg-18.3 {types: font} -returnCodes error -body { + tk::OptionType font validate "gorp {}gorp" +} -result {font "gorp {}gorp" doesn't exist} + +test oocfg-19.1 {types: image} { + tk::OptionType image default +} {} +test oocfg-19.2 {types: image} -setup { + image create photo testingImage +} -body { + tk::OptionType image validate testingImage +} -cleanup { + image delete testingImage +} -result testingImage +test oocfg-19.3 {types: image} { + tk::OptionType image validate {} +} {} +test oocfg-19.4 {types: image} -returnCodes error -body { + tk::OptionType image validate gorp +} -result {image "gorp" doesn't exist} + +test oocfg-20.1 {types: integer} { + tk::OptionType integer default +} 0 +test oocfg-20.2 {types: integer} { + tk::OptionType integer validate 0xff +} 255 +test oocfg-20.3 {types: integer} -returnCodes error -body { + tk::OptionType integer validate gorp +} -result {invalid integer value "gorp"} + +test oocfg-21.1 {types: justify} { + tk::OptionType justify default +} left +test oocfg-21.2 {types: justify} { + tk::OptionType justify validate r +} right +test oocfg-21.3 {types: justify} -returnCodes error -body { + tk::OptionType justify validate gorp +} -result {bad justify "gorp": must be center, left, or right} + +test oocfg-22.1 {types: list} { + tk::OptionType list default +} {} +test oocfg-22.2 {types: list} { + tk::OptionType list validate { + a + b + c + } +} {a b c} +test oocfg-22.3 {types: list} -returnCodes error -body { + tk::OptionType list validate "{}gorp" +} -result {invalid list value "{}gorp"} + +test oocfg-23.1 {types: relief} { + tk::OptionType relief default +} flat +test oocfg-23.2 {types: relief} { + tk::OptionType relief validate g +} groove +test oocfg-23.3 {types: relief} -returnCodes error -body { + tk::OptionType relief validate gorp +} -result {bad relief "gorp": must be flat, groove, raised, ridge, solid, or sunken} + +test oocfg-24.1 {types: string} { + tk::OptionType string default +} {} +test oocfg-24.2 {types: string} { + tk::OptionType string validate "abc de " +} "abc de " +# string type never fails validation and never alters values in normalization + +test oocfg-25.1 {types: window} { + tk::OptionType window default +} {} +test oocfg-25.2 {types: window} { + tk::OptionType window validate . +} . +test oocfg-25.3 {types: window} { + tk::OptionType window validate "" +} "" +test oocfg-25.4 {types: window} -returnCodes error -body { + tk::OptionType window validate gorp +} -result {invalid window value "gorp"} + +test oocfg-26.1 {types: zboolean} { + tk::OptionType zboolean default +} {} +test oocfg-26.2 {types: zboolean} { + tk::OptionType zboolean validate 0 +} false +test oocfg-26.3 {types: zboolean} { + tk::OptionType zboolean validate "" +} "" +test oocfg-26.4 {types: zboolean} -returnCodes error -body { + tk::OptionType zboolean validate gorp +} -result {invalid boolean value "gorp"} + +test oocfg-27.1 {types: zcolor} { + tk::OptionType zcolor default +} {} +test oocfg-27.2 {types: zcolor} { + tk::OptionType zcolor validate green +} "#008000" +test oocfg-27.3 {types: zcolor} { + tk::OptionType zcolor validate "" +} "" +test oocfg-27.4 {types: zcolor} -returnCodes error -body { + tk::OptionType zcolor validate gorp +} -result {unknown color name "gorp"} + +test oocfg-28.1 {types: zfloat} { + tk::OptionType zfloat default +} {} +test oocfg-28.2 {types: zfloat} { + tk::OptionType zfloat validate 1.2e3 +} 1200.0 +test oocfg-28.3 {types: zfloat} { + tk::OptionType zfloat validate "" +} "" +test oocfg-28.4 {types: zfloat} -returnCodes error -body { + tk::OptionType zfloat validate gorp +} -result {invalid float value "gorp"} + +test oocfg-29.1 {types: zinteger} { + tk::OptionType zinteger default +} {} +test oocfg-29.2 {types: zinteger} { + tk::OptionType zinteger validate 0xff +} 255 +test oocfg-29.3 {types: zinteger} { + tk::OptionType zinteger validate "" +} "" +test oocfg-29.4 {types: zinteger} -returnCodes error -body { + tk::OptionType zinteger validate gorp +} -result {invalid integer value "gorp"} + +# cleanup +deleteWindows +cleanupTests +return + +# Local Variables: +# mode: tcl +# End: Index: tests/option.test ================================================================== --- tests/option.test +++ tests/option.test @@ -36,11 +36,11 @@ option add *Class2.Color1 orange option add $appName.op2.op5.Color2 purple option add $appName.Class1.Class3.y brown option add $appName*op6*Color2 black option add $appName*Class1.op1.Color2 grey - + test option-1.1 {basic option retrieval} -body { option get . x Color1 } -result blue test option-1.2 {basic option retrieval} -body { option get . y Color1 @@ -55,11 +55,13 @@ option get . y Color2 } -result {} test option-1.6 {basic option retrieval} -body { option get . z Color2 } -result {} - +test option-1.7 {basic option retrieval} -body { + option get . z Color2 gorp +} -result gorp test option-2.1 {basic option retrieval} -body { option get .op1 x Color1 } -result green test option-2.2 {basic option retrieval} -body { @@ -76,11 +78,10 @@ } -result {} test option-2.6 {basic option retrieval} -body { option get .op1 z Color2 } -result {} - test option-3.1 {basic option retrieval} -body { option get .op1.op3 x Color1 } -result yellow test option-3.2 {basic option retrieval} -body { option get .op1.op3 y Color1 @@ -95,11 +96,10 @@ option get .op1.op3 y Color2 } -result {} test option-3.6 {basic option retrieval} -body { option get .op1.op3 z Color2 } -result {} - test option-4.1 {basic option retrieval} -body { option get .op1.op3.op6 x Color1 } -result blue test option-4.2 {basic option retrieval} -body { @@ -116,11 +116,10 @@ } -result black test option-4.6 {basic option retrieval} -body { option get .op1.op3.op6 z Color2 } -result black - test option-5.1 {basic option retrieval} -body { option get .op1.op4 x Color1 } -result blue test option-5.2 {basic option retrieval} -body { option get .op1.op4 y Color1 @@ -135,11 +134,10 @@ option get .op1.op4 y Color2 } -result brown test option-5.6 {basic option retrieval} -body { option get .op1.op4 z Color2 } -result {} - test option-6.1 {basic option retrieval} -body { option get .op2 x Color1 } -result orange test option-6.2 {basic option retrieval} -body { @@ -156,11 +154,10 @@ } -result {} test option-6.6 {basic option retrieval} -body { option get .op2 z Color2 } -result {} - test option-7.1 {basic option retrieval} -body { option get .op2.op5 x Color1 } -result orange test option-7.2 {basic option retrieval} -body { option get .op2.op5 y Color1 @@ -175,11 +172,10 @@ option get .op2.op5 y Color2 } -result purple test option-7.6 {basic option retrieval} -body { option get .op2.op5 z Color2 } -result purple - # Now try similar tests to above, except jump around non-hierarchically # between windows to make sure that the option stacks are pushed and # popped correctly. @@ -201,11 +197,10 @@ } -result purple test option-8.6 {stack pushing/popping} -body { option get .op2.op5 z Color2 } -result purple - test option-9.1 {stack pushing/popping} -body { option get . x Color1 } -result blue test option-9.2 {stack pushing/popping} -body { option get . y Color1 @@ -220,11 +215,10 @@ option get . y Color2 } -result {} test option-9.6 {stack pushing/popping} -body { option get . z Color2 } -result {} - test option-10.1 {stack pushing/popping} -body { option get .op1.op3.op6 x Color1 } -result blue test option-10.2 {stack pushing/popping} -body { @@ -241,11 +235,10 @@ } -result black test option-10.6 {stack pushing/popping} -body { option get .op1.op3.op6 z Color2 } -result black - test option-11.1 {stack pushing/popping} -body { option get .op1.op3 x Color1 } -result yellow test option-11.2 {stack pushing/popping} -body { option get .op1.op3 y Color1 @@ -260,11 +253,10 @@ option get .op1.op3 y Color2 } -result {} test option-11.6 {stack pushing/popping} -body { option get .op1.op3 z Color2 } -result {} - test option-12.1 {stack pushing/popping} -body { option get .op1 x Color1 } -result green test option-12.2 {stack pushing/popping} -body { @@ -316,11 +308,10 @@ option add $appName.op1.B file2 startupFile test option-13.7 {priority levels} -body { option get .op1 c B } -result file2 - # Test various error conditions test option-14.1 {error conditions} -body { option } -returnCodes error -result {wrong # args: should be "option cmd arg ?arg ...?"} @@ -345,21 +336,20 @@ test option-14.8 {error conditions} -body { option add . a gorp } -returnCodes error -result {bad priority level "gorp": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100} test option-14.9 {error conditions} -body { option get 3 -} -returnCodes error -result {wrong # args: should be "option get window name class"} +} -returnCodes error -result {wrong # args: should be "option get window name class ?default?"} test option-14.10 {error conditions} -body { option get 3 4 -} -returnCodes error -result {wrong # args: should be "option get window name class"} +} -returnCodes error -result {wrong # args: should be "option get window name class ?default?"} test option-14.11 {error conditions} -body { - option get 3 4 5 6 -} -returnCodes error -result {wrong # args: should be "option get window name class"} + option get 3 4 5 6 7 +} -returnCodes error -result {wrong # args: should be "option get window name class ?default?"} test option-14.12 {error conditions} -body { option get .gorp.gorp a A } -returnCodes error -result {bad window path name ".gorp.gorp"} - set option1 [file join [testsDirectory] option.file1] test option-15.1 {database files} -body { option read non-existent } -returnCodes error -result {couldn't open "non-existent": no such file or directory} @@ -401,41 +391,44 @@ } -returnCodes error -result {missing colon on line 2} set option3 [file join [testsDirectory] option.file3] option read $option3 test option-15.11 {database files} {option get . {x 4} color} brówn -test option-16.1 {ReadOptionFile} -body { +test option-16.1 {ReadOptionFile} -setup { set option4 [makeFile {} option.file3] +} -body { set file [open $option4 w] fconfigure $file -translation crlf puts $file "*x7: true\n*x8: false" close $file option read $option4 userDefault list [option get . x7 color] [option get . x8 color] } -cleanup { removeFile $option4 } -result {true false} - set opt162val {label { foo bar } } set opt162list [split $opt162val \n] - -test option-16.2 {ticket 766ef52f3} { +test option-16.2 {ticket 766ef52f3} -setup { set option5 [makeFile {} option.file4] +} -body { set file [open $option5 w] fconfigure $file -translation crlf puts $file "*notok: $opt162list" close $file option read $option5 userDefault option get . notok notok -} $opt162list - +} -cleanup { + removeFile $option5 +} -result $opt162list + deleteWindows # cleanup cleanupTests return - - +# Local Variables: +# mode: tcl +# End: