Tk Source Code

        uses: actions/checkout@v3
        with:
          path: tk
      - name: Checkout Tcl
        uses: actions/checkout@v3
        with:
          repository: tcltk/tcl
          ref: tip-558
          path: tcl
      - name: Setup Environment (compiler=${{ matrix.compiler }})
        run: |
          sudo apt-get install libxss-dev
          mkdir "$HOME/install dir"
          touch tk/doc/man.macros tk/generic/tkStubInit.c
          echo "CFGOPT=$CFGOPT" >> $GITHUB_ENV

        uses: actions/checkout@v3
        with:
          path: tk
      - name: Checkout Tcl
        uses: actions/checkout@v3
        with:
          repository: tcltk/tcl
          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"
          touch tk/doc/man.macros tk/generic/tkStubInit.c
          echo "CFGOPT=$CFGOPT" >> $GITHUB_ENV

        uses: actions/checkout@v3
        with:
          path: tk
      - name: Checkout Tcl 8.7
        uses: actions/checkout@v3
        with:
          repository: tcltk/tcl
          ref: tip-558
          path: tcl
      - name: Setup Environment
        run: |
          sudo apt-get install libxss-dev
          touch tcl/generic/tclStubInit.c tcl/generic/tclOOStubInit.c
          touch tk/generic/tkStubInit.c
          echo "INST_DIR=$(cd install;pwd)" >> $GITHUB_ENV

        uses: actions/checkout@v3
        with:
          path: tk
      - name: Checkout Tcl 8.7
        uses: actions/checkout@v3
        with:
          repository: tcltk/tcl
          ref: tip-558
          path: tcl
      - name: Checkout create-dmg
        uses: actions/checkout@v3
        with:
          repository: create-dmg/create-dmg
          ref: v1.0.8
          path: create-dmg

        uses: actions/checkout@v3
        with:
          path: tk
      - name: Checkout Tcl 8.7
        uses: actions/checkout@v3
        with:
          repository: tcltk/tcl
          ref: tip-558
          path: tcl
      - name: Setup Environment
        run: |
          mkdir -p install/combined
          touch tcl/generic/tclStubInit.c tcl/generic/tclOOStubInit.c
          touch tk/generic/tkStubInit.c
          echo "INST_DIR=$(cd install;pwd)" >> $GITHUB_ENV

        uses: actions/checkout@v3
        with:
          path: tk
      - name: Checkout
        uses: actions/checkout@v3
        with:
          repository: tcltk/tcl
          ref: tip-558
          path: tcl
      - name: Init MSVC
        uses: ilammy/msvc-dev-cmd@v1
      - name: Make Install Location
        working-directory: tcl
        run: |
          echo "TCLDIR=`pwd`" >> $GITHUB_ENV

'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
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 ?\fIdefault\fR?
\fBoption readfile \fIfileName \fR?\fIpriority\fR?
.fi
.BE
.SH DESCRIPTION
.PP
The \fBoption\fR command allows you to add entries to the Tk option
database or to retrieve options from the database.  The \fBadd\fR

specified for \fIwindow\fR
under \fIname\fR and \fIclass\fR.  If several entries in the option
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
.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
is specified, it indicates the priority level at which to enter the
options;  \fIpriority\fR defaults to \fBinteractive\fR.

     * Here is the real code:
     */

    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 --
 *
 *	This function returns debugging information about a cursor.

				 * Tk_AllocPreserveFromObj or Tk_Preserve). If
				 * this count is 0, then this structure is no
				 * 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
				 * 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). */
    Tcl_HashEntry *idHashPtr;	/* Entry in idTable for this structure (needed
				 * when deleting). */

/*
 * Unsupported commands.
 */

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,
			    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
#else
MODULE_SCOPE int	TkplatformtestInit(Tcl_Interp *interp);

	break;
    }

    case OPTION_GET: {
	Tk_Window window;
	Tk_Uid value;

	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;
	}
	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: {
	int priority;

    {"tk_messageBox",	Tk_MessageBoxObjCmd,	PASSMAINWINDOW},
#endif

    /*
     * Misc.
     */

    {"::tk::ParseCursor", TkParseCursorObjCmd,	PASSMAINWINDOW|ISSAFE},
#ifdef MAC_OSX_TK
    {"::tk::unsupported::MacWindowStyle",
			TkUnsupported1ObjCmd,	PASSMAINWINDOW|ISSAFE},
#endif
    {NULL,		NULL,			0}
};

# 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 <OptDescribe-$name> {} $descriptor]
		uplevel 1 [list \
		    forward <OptValidate-$name> {*}$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 {"<OptRead-$name>" ni $meths} {
		    uplevel 1 [list \
			forward <OptRead-$name> my <StdOptRead> $name]
		}

		# Note: init-only options still have this
		if {"<OptWrite-$name>" ni $meths} {
		    uplevel 1 [list \
			forward <OptWrite-$name> my <StdOptWrite> $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 <OptDescribe-$name> {} $descriptor]
		uplevel 1 [list \
		    forward <OptValidate-$name> my <OptValidate$otherName>]

		# Aliases always define readers and writers; overriding them
		# makes no sense at all!
		uplevel 1 [list \
		    forward <OptRead-$name> my <OptRead$otherName>]
		uplevel 1 [list \
		    forward <OptWrite-$name> my <OptWrite$otherName>]

		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 <OptDescribe$option>]
		::if {[::llength $desc] == 1} {
		    ::list $option {*}$desc
		} else {
		    ::list $option {*}$desc [my <OptRead$option>]
		}
	    }

	    # --------------------------------------------------------------
	    #
	    # 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 <OptionsMakeCheckpoint>]
		::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 <OptValidate$opt> $value]
			my <OptWrite$opt> $value
			::set stateChanged 1
		    }
		    ::if {$stateChanged} {
			my PostConfigure
		    }
		    ::unset -nocomplain checkpoint
		} finally {
		    # Rollback on error
		    ::if {[::info exists checkpoint]} {
			my <OptionsRestoreCheckpoint> $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 <OptRead[my GetRealOptionName $option]>]
	    } 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<Init> {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 <OptDescribe$opt>]
		    ::if {[llength $desc] == 1} {
			# Skip aliases
			::continue
		    }
		    ::lassign $desc nm cls def
		    ::set val [::option get $pathName $nm $cls $def]
		    ::if {[catch {my <OptValidate$opt> $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 <OptValidate$opt> $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 <OptWrite$opt> $value
	    }
	    ::set initialised true
	}
	forward Initialise my Impl<Init> Initialise
	forward Initialize my Impl<Init> 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 <StdOptRead> --
	#
	#	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 <StdOptRead> {name} {
	    ::variable ""
	    ::return $($name)
	}

	# ------------------------------------------------------------------
	#
	# tk::ConfigurableStandardImplementations <StdOptWrite> --
	#
	#	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 <StdOptWrite> {name value} {
	    ::variable ""
	    ::set ($name) $value
	}

	# ------------------------------------------------------------------
	#
	# tk::ConfigurableStandardImplementations <OptionsMakeCheckpoint> --
	#
	#	How to make a checkpoint of the state that can be restored if
	#	the configuration of the object fails. If overridden, the
	#	companion method <OptionsRestoreCheckpoint> should also be
	#	overridden. The format of checkpoints is undocumented
	#	formally, but this implementation uses a dictionary.
	#
	# ------------------------------------------------------------------

	method <OptionsMakeCheckpoint> {} {
	    ::variable ""
	    ::array get ""
	}

	# ------------------------------------------------------------------
	#
	# tk::ConfigurableStandardImplementations <OptionsRestoreCheckpoint> --
	#
	#	How to restore a checkpoint of the state because the
	#	configuration of the object has failed. If overridden, the
	#	companion method <OptionsMakeCheckpoint> should also be
	#	overridden. The format of checkpoints is undocumented
	#	formally, but this implementation uses a dictionary.
	#
	# ------------------------------------------------------------------

	method <OptionsRestoreCheckpoint> {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:

set ::tk::Priv(IMETextMark) [dict create]

# 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:

	foreach wincur(num) $wincur(data_octal) {
	    append wincur(data_binary) [binary format c [scan $wincur(num) %o]]
	}
	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
    button .b -cursor $x
    lindex $x 0

	button .b -text wait
} -body {
	.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:

# 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 <OptRead-foo> {} {
	    recordcall
	    tailcall my <StdOptRead> 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 <OptRead-foo> {} {
	    recordcall
	    tailcall my <StdOptRead> 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 <OptWrite-foo> value {
	    recordcall
	    tailcall my <StdOptWrite> 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 <OptWrite-foo> value {
	    recordcall
	    tailcall my <StdOptWrite> 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 <OptionsMakeCheckpoint> {} {
	    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 <OptionsRestoreCheckpoint> state {
	    variable ""
	    foreach p [info object properties [self] -all] v [split $state :] {
		set ([string trimleft $p -]) $v
	    }
	}
	export <OptionsMakeCheckpoint> <OptionsRestoreCheckpoint>
    }
    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 <OptionsMakeCheckpoint>] \
	[catch {gorp configure -foo 1 -bar x}] [gorp configure] \
	[gorp configure -foo 1 -bar 2] [gorp <OptionsMakeCheckpoint>] \
	[gorp <OptionsRestoreCheckpoint> 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 <OptionsMakeCheckpoint> <OptionsRestoreCheckpoint>
    }
    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 <OptionsMakeCheckpoint>] \
	[catch {gorp configure -foo 1 -bar x}] [gorp configure] \
	[gorp configure -foo 1 -bar 2] [gorp <OptionsMakeCheckpoint>] \
	[gorp <OptionsRestoreCheckpoint> {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:

option add *Class1.x yellow
option add $appName.op1.x green
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
} -result red
test option-1.3 {basic option retrieval} -body {
    option get . z Color1
} -result red
test option-1.4 {basic option retrieval} -body {
    option get . x Color2
} -result blue
test option-1.5 {basic option retrieval} -body {
    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 {
    option get .op1 y Color1
} -result red
test option-2.3 {basic option retrieval} -body {
    option get .op1 z Color1
} -result red
test option-2.4 {basic option retrieval} -body {
    option get .op1 x Color2
} -result green
test option-2.5 {basic option retrieval} -body {
    option get .op1 y Color2
} -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
} -result red
test option-3.3 {basic option retrieval} -body {
    option get .op1.op3 z Color1
} -result red
test option-3.4 {basic option retrieval} -body {
    option get .op1.op3 x Color2
} -result yellow
test option-3.5 {basic option retrieval} -body {
    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 {
    option get .op1.op3.op6 y Color1
} -result red
test option-4.3 {basic option retrieval} -body {
    option get .op1.op3.op6 z Color1
} -result red
test option-4.4 {basic option retrieval} -body {
    option get .op1.op3.op6 x Color2
} -result black
test option-4.5 {basic option retrieval} -body {
    option get .op1.op3.op6 y Color2
} -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
} -result brown
test option-5.3 {basic option retrieval} -body {
    option get .op1.op4 z Color1
} -result red
test option-5.4 {basic option retrieval} -body {
    option get .op1.op4 x Color2
} -result blue
test option-5.5 {basic option retrieval} -body {
    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 {
    option get .op2 y Color1
} -result orange
test option-6.3 {basic option retrieval} -body {
    option get .op2 z Color1
} -result orange
test option-6.4 {basic option retrieval} -body {
    option get .op2 x Color2
} -result blue
test option-6.5 {basic option retrieval} -body {
    option get .op2 y Color2
} -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
} -result orange
test option-7.3 {basic option retrieval} -body {
    option get .op2.op5 z Color1
} -result orange
test option-7.4 {basic option retrieval} -body {
    option get .op2.op5 x Color2
} -result purple
test option-7.5 {basic option retrieval} -body {
    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.

option get . foo Foo
test option-8.1 {stack pushing/popping} -body {

test option-8.5 {stack pushing/popping} -body {
    option get .op2.op5 y Color2
} -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
} -result red
test option-9.3 {stack pushing/popping} -body {
    option get . z Color1
} -result red
test option-9.4 {stack pushing/popping} -body {
    option get . x Color2
} -result blue
test option-9.5 {stack pushing/popping} -body {
    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 {
    option get .op1.op3.op6 y Color1
} -result red
test option-10.3 {stack pushing/popping} -body {
    option get .op1.op3.op6 z Color1
} -result red
test option-10.4 {stack pushing/popping} -body {
    option get .op1.op3.op6 x Color2
} -result black
test option-10.5 {stack pushing/popping} -body {
    option get .op1.op3.op6 y Color2
} -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
} -result red
test option-11.3 {stack pushing/popping} -body {
    option get .op1.op3 z Color1
} -result red
test option-11.4 {stack pushing/popping} -body {
    option get .op1.op3 x Color2
} -result yellow
test option-11.5 {stack pushing/popping} -body {
    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 {
    option get .op1 y Color1
} -result red

    option get .op1 c B
} -result startupFile
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 ...?"}
test option-14.2 {error conditions} -body {
    option x

    option add . a 101
} -returnCodes error -result {bad priority level "101": must be widgetDefault, startupFile, userDefault, interactive, or a number between 0 and 100}
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 ?default?"}
test option-14.10 {error conditions} -body {
    option get 3 4
} -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 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}
test option-15.2 {database files} -body {
    option read $option1

    set option2 [file join [testsDirectory] option.file2]
    option read $option2
} -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} -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} -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
} -cleanup {
    removeFile $option5
} -result $opt162list

deleteWindows

# cleanup
cleanupTests
return

# Local Variables:
# mode: tcl
# End: