'\"
'\" Copyright (c) 2019 Donal K. Fellows
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
.TH configurable n 0.1 TclOO "TclOO Commands"
.so man.macros
.BS
'\" Note:  do not modify the .SH NAME line immediately below!
.SH NAME
oo::configurable, configure, property \- class that makes configurable classes and objects, and supports making configurable properties
.SH SYNOPSIS
.nf
package require TclOO

\fBoo::configurable create \fIclass\fR \fR?\fIdefinitionScript\fR?

\fBoo::define \fIclass\fB {\fR
    \fBproperty \fIpropName\fR ?\fIoptions...\fR? ?\fIpropName\fR ?\fIoptions...\fR?...?
\fB}\fR

\fBoo::objdefine \fIobject\fB {\fR
    \fBproperty \fIpropName\fR ?\fIoptions...\fR? ?\fIpropName\fR ?\fIoptions...\fR?...?
\fB}\fR

\fIobjectName \fBconfigure\fR
\fIobjectName \fBconfigure\fR \fI\-prop\fR
\fIobjectName \fBconfigure\fR \fI\-prop value\fR ?\fI\-prop value\fR...\fR
.fi
.SH "CLASS HIERARCHY"
.nf
\fBoo::object\fR
   \(-> \fBoo::class\fR
       \(-> \fBoo::configurable\fR

\fBoo::object\fR
   \(-> \fBoo::class\fR
       \(-> \fBoo::configurablesupport::configurable\fR
.fi
.BE
.SH DESCRIPTION
.PP
Configurable objects are objects that support being configured with a
\fBconfigure\fR method. Each of the configurable entities of the object is
known as a property of the object. Properties may be defined on classes or
instances; when configuring an object, any of the properties defined by its
classes (direct or indirect) or by the instance itself may be configured.
.PP
The \fBoo::configurable\fR metaclass installs basic support for making
configurable objects into a class. This consists of making a \fBproperty\fR
definition command available in definition scripts for the class and instances
(e.g., from the class's constructor, within \fBoo::define\fR and within
\fBoo::objdefine\fR) and making a \fBconfigure\fR method available within the
instances.
.SS "CONFIGURE METHOD"
.PP
The behavior of the \fBconfigure\fR method is modelled after the
\fBfconfigure\fR/\fBchan configure\fR command.
.PP
If passed no additional arguments, the \fBconfigure\fR method returns an
alphabetically sorted dictionary of all \fIreadable\fR and \fIread-write\fR
properties and their current values.
.PP
If passed a single addiional argument, that argument to the \fBconfigure\fR
method must be the name of a property to read (or an unambiguous prefix
thereof); its value is returned.
.PP
Otherwise, if passed an even number of arguments then each pair of arguments
specifies a property name (or an unambiguous prefix thereof) and the value to
set it to. The properties will be set in the order specified, including
duplicates. If the setting of any property fails, the overall \fBconfigure\fR
method fails, the preceding pairs (if any) will continue to have been applied,
and the succeeding pairs (if any) will be not applied. On success, the result
of the \fBconfigure\fR method in this mode operation will be an empty string.
.SS "PROPERTY DEFINITIONS"
.PP
When a class has been manufactured by the \fBoo::configurable\fR metaclass (or
one of its subclasses), it gains an extra definition, \fBproperty\fR. The
\fBproperty\fR definition defines one or more properties that will be exposed
by the class's instances.
.PP
The \fBproperty\fR command takes the name of a property to define first,
\fIwithout a leading hyphen\fR, followed by a number of option-value pairs
that modify the basic behavior of the property. This can then be followed by
an arbitrary number of other property definitions. The supported options are:
.TP
\fB\-get \fIgetterScript\fR
.
This defines the implementation of how to read from the property; the
\fIgetterScript\fR will become the body of a method (taking no arguments)
defined on the class, if the kind of the property is such that the property
can be read from. The method will be named
\fB<ReadProp-\fIpropertyName\fB>\fR, and will default to being a simple read
of the instance variable with the same name as the property (e.g.,
.QW "\fBproperty\fR xyz"
will result in a method
.QW <ReadProp-xyz>
being created).
.TP
\fB\-kind \fIpropertyKind\fR
.
This defines what sort of property is being created. The \fIpropertyKind\fR
must be exactly one of \fBreadable\fR, \fBwritable\fR, or \fBreadwrite\fR
(which is the default) which will make the property read-only, write-only or
read-write, respectively.  Read-only properties can only ever be read from,
write-only properties can only ever be written to, and read-write properties
can be both read and written.
.RS
.PP
Note that write-only properties are not particularly discoverable as they are
never reported by the \fBconfigure\fR method other than by error messages when
attempting to write to a property that does not exist.
.RE
.TP
\fB\-set \fIsetterScript\fR
.
This defines the implementation of how to write to the property; the
\fIsetterScript\fR will become the body of a method taking a single argument,
\fIvalue\fR, defined on the class, if the kind of the property is such that
the property can be written to. The method will be named
\fB<WriteProp-\fIpropertyName\fB>\fR, and will default to being a simple write
of the instance variable with the same name as the property (e.g.,
.QW "\fBproperty\fR xyz"
will result in a method
.QW <WriteProp-xyz>
being created).
.PP
Instances of the class that was created by \fBoo::configurable\fR will also
support \fBproperty\fR definitions; the semantics will be exactly as above
except that the properties will be defined on the instance alone.
.PP
Note that the property implementation methods that \fBproperty\fR defines
should not be private, as this makes them inaccessible from the implementation
of \fBconfigure\fR (by design; the property configuration mechanism is
intended for use mainly from outside a class, whereas a class may access
variables directly). The variables accessed by the default implementations of
the properties \fImay\fR be private, if so declared.
.SH "ADVANCED USAGE"
.PP
The configurable class system is comprised of several pieces. The
\fBoo::configurable\fR metaclass works by mixing in a class and setting
definition namespaces during object creation that provide the other bits and
pieces of machinery. The key pieces of the implementation are enumerated here
so that they can be used by other code:
.TP
\fBoo::configuresupport::configurable\fR
.
This is a class that provids the implementation of the \fBconfigure\fR method
(described above in \fBCONFIGURE METHOD\fR).
.TP
\fBoo::configuresupport::configurableclass\fR
.
This is a namespace that contains the definition dialect that provides the
\fBproperty\fR declaration for use in classes (i.e., via \fBoo::define\fR, and
class constructors under normal circumstances), as described above in
\fBPROPERTY DEFINITIONS\fR. It \fBnamespace export\fRs its \fBproperty\fR
command so that it may be used easily in user definition dialects.
.TP
.
\fBoo::configuresupport::configurableobject\fR
.
This is a namespace that contains the definition dialect that provides the
\fBproperty\fR declaration for use in instance objects (i.e., via
\fBoo::objdefine\fR, and the\fB self\R declaration in \fBoo::define), as
described above in \fBPROPERTY DEFINITIONS\fR. It \fBnamespace export\fRs its
\fBproperty\fR command so that it may be used easily in user definition
dialects.
.PP
The underlying property discovery mechanism relies on four slots (see
\fBoo::define\fR for what that implies) that list the properties that can be
configured. These slots do not themselves impose any semantics on what the
slots mean other than that they have unique names, no important order, can be
inherited and discovered on classes and instances.
.PP
These slots, and their intended semantics, are:
.TP
\fBoo::configuresupport::readableproperties\fR
.
The set of properties of a class (not including those from its superclasses)
that may be read from when configuring an instance of the class. This slot can
also be read with the \fBinfo class properties\fR command.
.TP
\fBoo::configuresupport::writableproperties\fR
.
The set of properties of a class (not including those from its superclasses)
that may be written to when configuring an instance of the class. This slot
can also be read with the \fBinfo class properties\fR command.
.TP
\fBoo::configuresupport::objreadableproperties\fR
.
The set of properties of an object instance (not including those from its
classes) that may be read from when configuring the object. This slot can
also be read with the \fBinfo object properties\fR command.
.TP
\fBoo::configuresupport::objwritableproperties\fR
.
The set of properties of an object instance (not including those from its
classes) that may be written to when configuring the object. This slot can
also be read with the \fBinfo object properties\fR command.
.PP
Note that though these are slots, they are \fInot\fR in the standard
\fBoo::define\fR or \fBoo::objdefine\fR namespaces; in order to use them
inside a definition script, they need to be referred to by full name. This is
because they are intended to be building bricks of configurable property
system, and not directly used by normal user code.
.SS "IMPLEMENTATION NOTE"
.PP
The implementation of the \fBconfigure\fR method uses
\fBinfo object properties\fR with the \fB\-all\fR option to discover what
properties it may manipulate.
.SH EXAMPLES
.PP
Here we create a simple configurable class and demonstrate how it can be
configured:
.PP
.CS
\fBoo::configurable\fR create Point {
    \fBproperty\fR x y
    constructor args {
        my \fBconfigure\fR -x 0 -y 0 {*}$args
    }
    variable x y
    method print {} {
        puts "x=$x, y=$y"
    }
}

set pt [Point new -x 27]
$pt print;   \fI# x=27, y=0\fR
$pt \fBconfigure\fR -y 42
$pt print;   \fI# x=27, y=42\fR
puts "distance from origin: [expr {
    hypot([$pt \fBconfigure\fR -x], [$pt \fBconfigure\fR -y])
}]";         \fI# distance from origin: 49.92995093127971\fR
puts [$pt \fBconfigure\fR]
             \fI# -x 27 -y 42\fR
.CE
.PP
Such a configurable class can be extended by subclassing, though the subclass
needs to also be created by \fBoo::configurable\fR if it will use the
\fBproperty\fR definition:
.PP
.CS
\fBoo::configurable\fR create Point3D {
    superclass Point
    \fBproperty\fR z
    constructor args {
        next -z 0 {*}$args
    }
}

set pt2 [Point3D new -x 2 -y 3 -z 4]
puts [$pt2 \fBconfigure\fR]
             \fI# -x 2 -y 3 -z 4\fR
.CE
.PP
Once you have a configurable class, you can also add instance properties to
it. (The backing variables for all properties start unset.) Note below that we
are using an unambiguous prefix of a property name when setting it; this is
supported for all properties though full names are normally recommended
because subclasses will not make an unambiguous prefix become ambiguous in
that case.
.PP
.CS
oo::objdefine $pt {
    \fBproperty\fR color
}
$pt \fBconfigure\fR -c bisque
puts [$pt \fBconfigure\fR]
             \fI# -color bisque -x 27 -y 42\fR
.CE
.PP
You can also do derived properties by making them read-only and supplying a
script that computes them.
.PP
.CS
\fBoo::configurable\fR create PointMk2 {
    \fBproperty\fR x y
    \fBproperty\fR distance -kind readable -get {
        return [expr {hypot($x, $y)}]
    }
    variable x y
    constructor args {
        my \fBconfigure\fR -x 0 -y 0 {*}$args
    }
}

set pt3 [PointMk2 new -x 3 -y 4]
puts [$pt3 \fBconfigure\fR -distance]
             \fI# 5.0\fR
$pt3 \fBconfigure\fR -distance 10
             \fI# ERROR: bad property "-distance": must be -x or -y\fR
.CE
.PP
Setters are used to validate the type of a property:
.PP
.CS
\fBoo::configurable\fR create PointMk3 {
    \fBproperty\fR x -set {
        if {![string is double -strict $value]} {
            error "-x property must be a number"
        }
        set x $value
    }
    \fBproperty\fR y -set {
        if {![string is double -strict $value]} {
            error "-y property must be a number"
        }
        set y $value
    }
    variable x y
    constructor args {
        my \fBconfigure\fR -x 0 -y 0 {*}$args
    }
}

set pt4 [PointMk3 new]
puts [$pt4 \fBconfigure\fR]
             \fI# -x 0 -y 0\fR
$pt4 \fBconfigure\fR -x 3 -y 4
puts [$pt4 \fBconfigure\fR]
             \fI# -x 3 -y 4\fR
$pt4 \fBconfigure\fR -x "obviously not a number"
             \fI# ERROR: -x property must be a number\fR
.CE
.SH "SEE ALSO"
info(n), oo::class(n), oo::define(n)
.SH KEYWORDS
class, object, properties, configuration
.\" Local variables:
.\" mode: nroff
.\" fill-column: 78
.\" End:

of values (class names, variable names, etc.) that comprises the contents of
the slot. The class defines five operations (as methods) that may be done on
the slot:
.TP
\fIslot\fR \fB\-append\fR ?\fImember ...\fR?
.
This appends the given \fImember\fR elements to the slot definition.
.TP
\fIslot\fR \fB\-appendifnew\fR ?\fImember ...\fR?
.VS TIP558
This appends the given \fImember\fR elements to the slot definition if they
do not already exist.
.VE TIP558
.TP
\fIslot\fR \fB\-clear\fR
.
This sets the slot definition to the empty list.
.TP
\fIslot\fR \fB\-prepend\fR ?\fImember ...\fR?
.VS TIP516

definition\fR, and when the result is \fBforward\fR, further information can
be discovered with \fBinfo class forward\fR.
.TP
\fBinfo class mixins\fI class\fR
.
This subcommand returns a list of all classes that have been mixed into the
class named \fIclass\fR.
.TP
\fBinfo class properties\fI class\fR ?\fIoptions...\fR
.VS "TIP 558"
This subcommand returns a sorted list of properties defined on the class named
\fIclass\fR. The \fIoptions\fR define exactly which properties are returned:
.RS
.TP
\fB\-all\fR
.
With this option, the properties from the superclasses and mixins of the class
are also returned.
.TP
\fB\-readable\fR
.
This option (the default behavior) asks for the readable properties to be
returned. Only readable or writable properties are returned, not both.
.TP
\fB\-writable\fR
.
This option asks for the writable properties to be returned.  Only readable or
writable properties are returned, not both.
.RE
.VE "TIP 558"
.TP
\fBinfo class subclasses\fI class\fR ?\fIpattern\fR?
.
This subcommand returns a list of direct subclasses of class \fIclass\fR. If
the optional \fIpattern\fR argument is present, it constrains the list of
returned classes to those that match it according to the rules of
\fBstring match\fR.

This subcommand returns a list of all classes that have been mixed into the
object named \fIobject\fR.
.TP
\fBinfo object namespace\fI object\fR
.
This subcommand returns the name of the internal namespace of the object named
\fIobject\fR.
.TP
\fBinfo object properties\fI object\fR ?\fIoptions...\fR
.VS "TIP 558"
This subcommand returns a sorted list of properties defined on the object
named \fIobject\fR. The \fIoptions\fR define exactly which properties are
returned:
.RS
.TP
\fB\-all\fR
.
With this option, the properties from the class, superclasses and mixins of
the object are also returned.
.TP
\fB\-readable\fR
.
This option (the default behavior) asks for the readable properties to be
returned. Only readable or writable properties are returned, not both.
.TP
\fB\-writable\fR
.
This option asks for the writable properties to be returned. Only readable or
writable properties are returned, not both.
.RE
.VE "TIP 558"
.TP
\fBinfo object variables\fI object\fRR ?\fB\-private\fR?
.
This subcommand returns a list of all variables that have been declared for
the object named \fIobject\fR (i.e. that are automatically present in the
object's methods).
.VS TIP500

/*
 * tclOO.c --
 *
 *	This file contains the object-system core (NB: not Tcl_Obj, but ::oo)
 *
 * Copyright © 2005-2012 Donal K. Fellows
 * Copyright © 2005-2019 Donal K. Fellows
 * Copyright © 2017 Nathan Coulter
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#ifdef HAVE_CONFIG_H

    Tcl_Export(interp, fPtr->ooNs, "[a-z]*", 1);
    fPtr->defineNs = Tcl_CreateNamespace(interp, "::oo::define", fPtr,
	    DeletedDefineNamespace);
    fPtr->objdefNs = Tcl_CreateNamespace(interp, "::oo::objdefine", fPtr,
	    DeletedObjdefNamespace);
    fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr,
	    DeletedHelpersNamespace);
    Tcl_CreateNamespace(interp, "::oo::configuresupport", NULL, NULL);
    fPtr->epoch = 0;
    fPtr->tsdPtr = tsdPtr;
    TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
    TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
    TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
    TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
    TclNewLiteralStringObj(fPtr->defineName, "::oo::define");

    Object *oPtr)		/* The object representing the class. */
{
    FOREACH_HASH_DECLS;
    int i;
    Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
    Method *mPtr;
    Foundation *fPtr = oPtr->fPtr;
    Tcl_Obj *variableObj;
    Tcl_Obj *variableObj, *propertyObj;
    PrivateVariableMapping *privateVariable;

    /*
     * Sanity check!
     */

    if (!Destructing(oPtr)) {

	FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
	    TclOODeleteChain(callPtr);
	}
	Tcl_DeleteHashTable(clsPtr->classChainCache);
	ckfree(clsPtr->classChainCache);
	clsPtr->classChainCache = NULL;
    }

    /*
     * Squelch the property lists.
     */

    if (clsPtr->properties.allReadableCache) {
	Tcl_DecrRefCount(clsPtr->properties.allReadableCache);
    }
    if (clsPtr->properties.allWritableCache) {
	Tcl_DecrRefCount(clsPtr->properties.allWritableCache);
    }
    if (clsPtr->properties.readable.num) {
	FOREACH(propertyObj, clsPtr->properties.readable) {
	    Tcl_DecrRefCount(propertyObj);
	}
	ckfree(clsPtr->properties.readable.list);
    }
    if (clsPtr->properties.writable.num) {
	FOREACH(propertyObj, clsPtr->properties.writable) {
	    Tcl_DecrRefCount(propertyObj);
	}
	ckfree(clsPtr->properties.writable.list);
    }

    /*
     * Squelch our filter list.
     */

    if (clsPtr->filters.num) {
	Tcl_Obj *filterObj;

				 * being deleted. */
{
    Object *oPtr = (Object *)clientData;
    Foundation *fPtr = oPtr->fPtr;
    FOREACH_HASH_DECLS;
    Class *mixinPtr;
    Method *mPtr;
    Tcl_Obj *filterObj, *variableObj;
    Tcl_Obj *filterObj, *variableObj, *propertyObj;
    PrivateVariableMapping *privateVariable;
    Tcl_Interp *interp = oPtr->fPtr->interp;
    int i;

    if (Destructing(oPtr)) {
	/*
	 * TODO:  Can ObjectNamespaceDeleted ever be called twice?  If not,

	FOREACH_HASH(metadataTypePtr, value, oPtr->metadataPtr) {
	    metadataTypePtr->deleteProc(value);
	}
	Tcl_DeleteHashTable(oPtr->metadataPtr);
	ckfree(oPtr->metadataPtr);
	oPtr->metadataPtr = NULL;
    }

    /*
     * Squelch the property lists.
     */

    if (oPtr->properties.allReadableCache) {
	Tcl_DecrRefCount(oPtr->properties.allReadableCache);
    }
    if (oPtr->properties.allWritableCache) {
	Tcl_DecrRefCount(oPtr->properties.allWritableCache);
    }
    if (oPtr->properties.readable.num) {
	FOREACH(propertyObj, oPtr->properties.readable) {
	    Tcl_DecrRefCount(propertyObj);
	}
	ckfree(oPtr->properties.readable.list);
    }
    if (oPtr->properties.writable.num) {
	FOREACH(propertyObj, oPtr->properties.writable) {
	    Tcl_DecrRefCount(propertyObj);
	}
	ckfree(oPtr->properties.writable.list);
    }

    /*
     * Because an object can be a class that is an instance of itself, the
     * class object's class structure should only be cleaned after most of
     * the cleanup on the object is done.
     *
     * The class of objects needs some special care; if it is deleted (and

/*
 * tclOOCall.c --
 *
 *	This file contains the method call chain management code for the
 *	object-system core.
 *	object-system core. It also contains everything else that does
 *	inheritance hierarchy traversal.
 *
 * Copyright © 2005-2012 Donal K. Fellows
 * Copyright © 2005-2019 Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#ifdef HAVE_CONFIG_H
#include "config.h"

#define DEFINITE_PROTECTED 0x100000
#define DEFINITE_PUBLIC    0x200000
#define KNOWN_STATE	   (DEFINITE_PROTECTED | DEFINITE_PUBLIC)
#define SPECIAL		   (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN)
#define BUILDING_MIXINS	   0x400000
#define TRAVERSED_MIXIN	   0x800000
#define OBJECT_MIXIN	   0x1000000
#define DEFINE_FOR_CLASS   0x2000000
#define MIXIN_CONSISTENT(flags) \
    (((flags) & OBJECT_MIXIN) ||					\
	!((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN))

/*
 * Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for
 * Itcl's special type of private.

				 * [oo::define], otherwise, we are going to
				 * use this for [oo::objdefine]. */
{
    DefineChain define;
    DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE];
    DefineEntry *entryPtr;
    Tcl_Namespace *nsPtr = NULL;
    int i;
    int i, flags = (forClass ? DEFINE_FOR_CLASS : 0);

    define.list = staticSpace;
    define.num = 0;
    define.size = DEFINE_CHAIN_STATIC_SIZE;

    /*
     * Add the actual define locations. We have to do this twice to handle
     * class mixins right.
     */

    AddSimpleDefineNamespaces(oPtr, &define, forClass | BUILDING_MIXINS);
    AddSimpleDefineNamespaces(oPtr, &define, forClass);
    AddSimpleDefineNamespaces(oPtr, &define, flags | BUILDING_MIXINS);
    AddSimpleDefineNamespaces(oPtr, &define, flags);

    /*
     * Go through the list until we find a namespace whose name we can
     * resolve.
     */

    FOREACH_STRUCT(entryPtr, define) {

  tailRecurse:
    FOREACH(superPtr, classPtr->mixins) {
	AddSimpleClassDefineNamespaces(superPtr, definePtr,
		flags | TRAVERSED_MIXIN);
    }

    if (flags & ~(TRAVERSED_MIXIN | BUILDING_MIXINS)) {
    if (flags & DEFINE_FOR_CLASS) {
	AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs,
		definePtr, flags);
    } else {
	AddDefinitionNamespaceToChain(classPtr, classPtr->objDefinitionNs,
		definePtr, flags);
    }

		    sizeof(DefineEntry) * definePtr->size);
	}
    }
    definePtr->list[i].definerCls = definerCls;
    definePtr->list[i].namespaceName = namespaceName;
    definePtr->num++;
}

static void
FindClassProps(
    Class *clsPtr,
    int writable,
    Tcl_HashTable *accumulator)
{
    int i, dummy;
    Tcl_Obj *propName;
    Class *mixin, *sup;

  tailRecurse:
    if (writable) {
	FOREACH(propName, clsPtr->properties.writable) {
	    Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
	}
    } else {
	FOREACH(propName, clsPtr->properties.readable) {
	    Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
	}
    }
    if (clsPtr->thisPtr->flags & ROOT_OBJECT) {
	/*
	 * We do *not* traverse upwards from the root!
	 */
	return;
    }
    FOREACH(mixin, clsPtr->mixins) {
	FindClassProps(mixin, writable, accumulator);
    }
    if (clsPtr->superclasses.num == 1) {
	clsPtr = clsPtr->superclasses.list[0];
	goto tailRecurse;
    }
    FOREACH(sup, clsPtr->superclasses) {
	FindClassProps(sup, writable, accumulator);
    }
}

static void
FindObjectProps(
    Object *oPtr,
    int writable,
    Tcl_HashTable *accumulator)
{
    int i, dummy;
    Tcl_Obj *propName;
    Class *mixin;

    if (writable) {
	FOREACH(propName, oPtr->properties.writable) {
	    Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
	}
    } else {
	FOREACH(propName, oPtr->properties.readable) {
	    Tcl_CreateHashEntry(accumulator, (void *) propName, &dummy);
	}
    }
    FOREACH(mixin, oPtr->mixins) {
	FindClassProps(mixin, writable, accumulator);
    }
    FindClassProps(oPtr->selfCls, writable, accumulator);
}

Tcl_Obj *
TclOOGetAllClassProperties(
    Class *clsPtr,
    int writable,
    int *allocated)
{
    Tcl_HashTable hashTable;
    FOREACH_HASH_DECLS;
    Tcl_Obj *propName, *result;
    void *dummy;

    /*
     * Look in the cache.
     */

    if (clsPtr->properties.epoch == clsPtr->thisPtr->fPtr->epoch) {
	if (writable) {
	    if (clsPtr->properties.allWritableCache) {
		*allocated = 0;
		return clsPtr->properties.allWritableCache;
	    }
	} else {
	    if (clsPtr->properties.allReadableCache) {
		*allocated = 0;
		return clsPtr->properties.allReadableCache;
	    }
	}
    }

    /*
     * Gather the information. Unsorted! (Caller will sort.)
     */

    *allocated = 1;
    Tcl_InitObjHashTable(&hashTable);
    FindClassProps(clsPtr, writable, &hashTable);
    result = Tcl_NewObj();
    FOREACH_HASH(propName, dummy, &hashTable) {
	Tcl_ListObjAppendElement(NULL, result, propName);
    }
    Tcl_DeleteHashTable(&hashTable);

    /*
     * Cache the information. Also purges the cache.
     */

    if (clsPtr->properties.epoch != clsPtr->thisPtr->fPtr->epoch) {
	if (clsPtr->properties.allWritableCache) {
	    Tcl_DecrRefCount(clsPtr->properties.allWritableCache);
	    clsPtr->properties.allWritableCache = NULL;
	}
	if (clsPtr->properties.allReadableCache) {
	    Tcl_DecrRefCount(clsPtr->properties.allReadableCache);
	    clsPtr->properties.allReadableCache = NULL;
	}
    }
    clsPtr->properties.epoch = clsPtr->thisPtr->fPtr->epoch;
    if (writable) {
	clsPtr->properties.allWritableCache = result;
    } else {
	clsPtr->properties.allReadableCache = result;
    }
    Tcl_IncrRefCount(result);
    return result;
}

Tcl_Obj *
TclOOGetAllObjectProperties(
    Object *oPtr,
    int writable,
    int *allocated)
{
    Tcl_HashTable hashTable;
    FOREACH_HASH_DECLS;
    Tcl_Obj *propName, *result;
    void *dummy;

    /*
     * Look in the cache.
     */

    if (oPtr->properties.epoch == oPtr->fPtr->epoch) {
	if (writable) {
	    if (oPtr->properties.allWritableCache) {
		*allocated = 0;
		return oPtr->properties.allWritableCache;
	    }
	} else {
	    if (oPtr->properties.allReadableCache) {
		*allocated = 0;
		return oPtr->properties.allReadableCache;
	    }
	}
    }

    /*
     * Gather the information. Unsorted! (Caller will sort.)
     */

    *allocated = 1;
    Tcl_InitObjHashTable(&hashTable);
    FindObjectProps(oPtr, writable, &hashTable);
    result = Tcl_NewObj();
    FOREACH_HASH(propName, dummy, &hashTable) {
	Tcl_ListObjAppendElement(NULL, result, propName);
    }
    Tcl_DeleteHashTable(&hashTable);

    /*
     * Cache the information.
     */

    if (oPtr->properties.epoch != oPtr->fPtr->epoch) {
	if (oPtr->properties.allWritableCache) {
	    Tcl_DecrRefCount(oPtr->properties.allWritableCache);
	    oPtr->properties.allWritableCache = NULL;
	}
	if (oPtr->properties.allReadableCache) {
	    Tcl_DecrRefCount(oPtr->properties.allReadableCache);
	    oPtr->properties.allReadableCache = NULL;
	}
    }
    oPtr->properties.epoch = oPtr->fPtr->epoch;
    if (writable) {
	oPtr->properties.allWritableCache = result;
    } else {
	oPtr->properties.allReadableCache = result;
    }
    Tcl_IncrRefCount(result);
    return result;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

/*
 * tclOODefineCmds.c --
 *
 *	This file contains the implementation of the ::oo::define command,
 *	part of the object-system core (NB: not Tcl_Obj, but ::oo).
 *
 * Copyright © 2006-2013 Donal K. Fellows
 * Copyright © 2006-2019 Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#ifdef HAVE_CONFIG_H
#include "config.h"

#define PUBLIC_PATTERN		"[a-z]*"

/*
 * Forward declarations.
 */

static inline void	BumpGlobalEpoch(Tcl_Interp *interp, Class *classPtr);
static inline void	BumpInstanceEpoch(Object *oPtr);
static Tcl_Command	FindCommand(Tcl_Interp *interp, Tcl_Obj *stringObj,
			    Tcl_Namespace *const namespacePtr);
static inline void	GenerateErrorInfo(Tcl_Interp *interp, Object *oPtr,
			    Tcl_Obj *savedNameObj, const char *typeOfSubject);
static inline int	MagicDefinitionInvoke(Tcl_Interp *interp,
			    Tcl_Namespace *nsPtr, int cmdIndex,
			    int objc, Tcl_Obj *const *objv);
static inline Class *	GetClassInOuterContext(Tcl_Interp *interp,
			    Tcl_Obj *className, const char *errMsg);
static inline Tcl_Namespace *GetNamespaceInOuterContext(Tcl_Interp *interp,
			    Tcl_Obj *namespaceName);
static inline int	InitDefineContext(Tcl_Interp *interp,
			    Tcl_Namespace *namespacePtr, Object *oPtr,
			    int objc, Tcl_Obj *const objv[]);
static inline void	RecomputeClassCacheFlag(Object *oPtr);
static int		RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
			    int useClass, Tcl_Obj *const fromPtr,
			    Tcl_Obj *const toPtr);
static int		ClassFilterGet(ClientData clientData,
static Tcl_MethodCallProc ClassFilterGet, ClassFilterSet;
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassFilterSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassMixinGet(ClientData clientData,
static Tcl_MethodCallProc ClassMixinGet, ClassMixinSet;
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassMixinSet(ClientData clientData,
static Tcl_MethodCallProc ClassRPropsGet, ClassRPropsSet;
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassSuperGet(ClientData clientData,
static Tcl_MethodCallProc ClassSuperGet, ClassSuperSet;
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassSuperSet(ClientData clientData,
static Tcl_MethodCallProc ClassVarsGet, ClassVarsSet;
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassVarsGet(ClientData clientData,
static Tcl_MethodCallProc ClassWPropsGet, ClassWPropsSet;
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ClassVarsSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjFilterGet(ClientData clientData,
static Tcl_MethodCallProc ObjFilterGet, ObjFilterSet;
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjFilterSet(ClientData clientData,
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjMixinGet(ClientData clientData,
static Tcl_MethodCallProc ObjMixinGet, ObjMixinSet;
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjMixinSet(ClientData clientData,
static Tcl_MethodCallProc ObjRPropsGet, ObjRPropsSet;
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjVarsGet(ClientData clientData,
static Tcl_MethodCallProc ObjVarsGet, ObjVarsSet;
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ObjVarsSet(ClientData clientData,
static Tcl_MethodCallProc ObjWPropsGet, ObjWPropsSet;
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);
static int		ResolveClass(ClientData clientData,
static Tcl_MethodCallProc ResolveClass;
			    Tcl_Interp *interp, Tcl_ObjectContext context,
			    int objc, Tcl_Obj *const *objv);

/*
 * Now define the slots used in declarations.
 */

static const struct DeclaredSlot slots[] = {
    SLOT("define::filter",      ClassFilterGet, ClassFilterSet, NULL),
    SLOT("define::mixin",       ClassMixinGet,  ClassMixinSet, ResolveClass),
    SLOT("define::superclass",  ClassSuperGet,  ClassSuperSet, ResolveClass),
    SLOT("define::variable",    ClassVarsGet,   ClassVarsSet, NULL),
    SLOT("objdefine::filter",   ObjFilterGet,   ObjFilterSet, NULL),
    SLOT("objdefine::mixin",    ObjMixinGet,    ObjMixinSet, ResolveClass),
    SLOT("objdefine::variable", ObjVarsGet,     ObjVarsSet, NULL),
    SLOT("configuresupport::readableproperties",
	    ClassRPropsGet, ClassRPropsSet, NULL),
    SLOT("configuresupport::writableproperties",
	    ClassWPropsGet, ClassWPropsSet, NULL),
    SLOT("configuresupport::objreadableproperties",
	    ObjRPropsGet, ObjRPropsSet, NULL),
    SLOT("configuresupport::objwritableproperties",
	    ObjWPropsGet, ObjWPropsSet, NULL),
    {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}}
};

/*
 * How to build the in-namespace name of a private variable. This is a pattern
 * used with Tcl_ObjPrintf().
 */

	 * invalidate any call chains. Note that we still bump our object's
	 * epoch if it has any mixins; the relation between a class and its
	 * representative object is special. But it won't hurt.
	 */

	if (classPtr->thisPtr->mixins.num > 0) {
	    classPtr->thisPtr->epoch++;

	    /*
	     * Invalidate the property caches directly.
	     */

	    if (classPtr->properties.allReadableCache) {
		Tcl_DecrRefCount(classPtr->properties.allReadableCache);
		classPtr->properties.allReadableCache = NULL;
	    }
	    if (classPtr->properties.allWritableCache) {
		Tcl_DecrRefCount(classPtr->properties.allWritableCache);
		classPtr->properties.allWritableCache = NULL;
	    }
	}
	return;
    }

    /*
     * Either there's no class (?!) or we're reconfiguring something that is
     * in use. Force regeneration of call chains.
     * in use. Force regeneration of call chains and properties.
     */

    TclOOGetFoundation(interp)->epoch++;
}

/*
 * ----------------------------------------------------------------------
 *
 * BumpInstanceEpoch --
 *
 *	Advances the epoch and clears the property cache of an object. The
 *	equivalent for classes is BumpGlobalEpoch(), as classes have a more
 *	complex set of relationships to other entities.
 *
 * ----------------------------------------------------------------------
 */

static inline void
BumpInstanceEpoch(
    Object *oPtr)
{
    oPtr->epoch++;
    if (oPtr->properties.allReadableCache) {
	Tcl_DecrRefCount(oPtr->properties.allReadableCache);
	oPtr->properties.allReadableCache = NULL;
    }
    if (oPtr->properties.allWritableCache) {
	Tcl_DecrRefCount(oPtr->properties.allWritableCache);
	oPtr->properties.allWritableCache = NULL;
    }
}

/*
 * ----------------------------------------------------------------------
 *
 * RecomputeClassCacheFlag --
 *
 *	Determine whether the object is prototypical of its class, and hence

	    filtersList[i] = filters[i];
	    Tcl_IncrRefCount(filters[i]);
	}
	oPtr->filters.list = filtersList;
	oPtr->filters.num = numFilters;
	oPtr->flags &= ~USE_CLASS_CACHE;
    }
    oPtr->epoch++;		/* Only this object can be affected. */
    BumpInstanceEpoch(oPtr);	/* Only this object can be affected. */
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOClassSetFilters --
 *

		 * For the new copy created by memcpy().
		 */

		AddRef(mixinPtr->thisPtr);
	    }
	}
    }
    oPtr->epoch++;
    BumpInstanceEpoch(oPtr);
}

/*
 * ----------------------------------------------------------------------
 *
 * TclOOClassSetMixins --
 *

 *
 * InstallStandardVariableMapping, InstallPrivateVariableMapping --
 *
 *	Helpers for installing standard and private variable maps.
 *
 * ----------------------------------------------------------------------
 */

static inline void
InstallStandardVariableMapping(
    VariableNameList *vnlPtr,
    int varc,
    Tcl_Obj *const *varv)
{
    Tcl_Obj *variableObj;

	} else if (!wasClass && willBeClass) {
	    TclOOAllocClass(interp, oPtr);
	}

	if (oPtr->classPtr != NULL) {
	    BumpGlobalEpoch(interp, oPtr->classPtr);
	} else {
	    oPtr->epoch++;
	    BumpInstanceEpoch(oPtr);
	}
    }
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------

	if (RenameDeleteMethod(interp, oPtr, !isInstanceDeleteMethod,
		objv[i], NULL) != TCL_OK) {
	    return TCL_ERROR;
	}
    }

    if (isInstanceDeleteMethod) {
	oPtr->epoch++;
	BumpInstanceEpoch(oPtr);
    } else {
	BumpGlobalEpoch(interp, oPtr->classPtr);
    }
    return TCL_OK;
}

/*

    /*
     * Bump the right epoch if we actually changed anything.
     */

    if (changed) {
	if (isInstanceExport) {
	    oPtr->epoch++;
	    BumpInstanceEpoch(oPtr);
	} else {
	    BumpGlobalEpoch(interp, clsPtr);
	}
    }
    return TCL_OK;
}


    if (RenameDeleteMethod(interp, oPtr, !isInstanceRenameMethod,
	    objv[1], objv[2]) != TCL_OK) {
	return TCL_ERROR;
    }

    if (isInstanceRenameMethod) {
	oPtr->epoch++;
	BumpInstanceEpoch(oPtr);
    } else {
	BumpGlobalEpoch(interp, oPtr->classPtr);
    }
    return TCL_OK;
}

/*

    /*
     * Bump the right epoch if we actually changed anything.
     */

    if (changed) {
	if (isInstanceUnexport) {
	    oPtr->epoch++;
	    BumpInstanceEpoch(oPtr);
	} else {
	    BumpGlobalEpoch(interp, clsPtr);
	}
    }
    return TCL_OK;
}


	Tcl_SetObjResult(interp, objv[idx]);
    } else {
	Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr));
    }

    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * ClassRPropsGet, ClassRPropsSet, ObjRPropsGet, ObjRPropsSet --
 *
 *	Implementations of the "readableproperties" slot accessors for classes
 *	and instances.
 *
 * ----------------------------------------------------------------------
 */

static void
InstallReadableProps(
    PropertyStorage *props,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *propObj;
    int i, n, created;
    Tcl_HashTable uniqueTable;

    if (props->allReadableCache) {
	Tcl_DecrRefCount(props->allReadableCache);
	props->allReadableCache = NULL;
    }

    for (i=0 ; i<objc ; i++) {
	Tcl_IncrRefCount(objv[i]);
    }
    FOREACH(propObj, props->readable) {
	Tcl_DecrRefCount(propObj);
    }
    if (i != objc) {
	if (objc == 0) {
	    ckfree(props->readable.list);
	} else if (i) {
	    props->readable.list = (Tcl_Obj **)ckrealloc(props->readable.list,
		    sizeof(Tcl_Obj *) * objc);
	} else {
	    props->readable.list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc);
	}
    }
    props->readable.num = 0;
    if (objc > 0) {
	Tcl_InitObjHashTable(&uniqueTable);
	for (i=n=0 ; i<objc ; i++) {
	    Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
	    if (created) {
		props->readable.list[n++] = objv[i];
	    } else {
		Tcl_DecrRefCount(objv[i]);
	    }
	}
	props->readable.num = n;

	/*
	 * Shouldn't be necessary, but maintain num/list invariant.
	 */

	if (n != objc) {
	    props->readable.list = (Tcl_Obj **)ckrealloc(props->readable.list,
		    sizeof(Tcl_Obj *) * n);
	}
	Tcl_DeleteHashTable(&uniqueTable);
    }
}

static int
ClassRPropsGet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *propNameObj;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(propNameObj, oPtr->classPtr->properties.readable) {
	Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ClassRPropsSet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int varc;
    Tcl_Obj **varv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    InstallReadableProps(&oPtr->classPtr->properties, varc, varv);
    BumpGlobalEpoch(interp, oPtr->classPtr);
    return TCL_OK;
}

static int
ObjRPropsGet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *propNameObj;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(propNameObj, oPtr->properties.readable) {
	Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ObjRPropsSet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int varc;
    Tcl_Obj **varv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"filterList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    InstallReadableProps(&oPtr->properties, varc, varv);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * ClassWPropsGet, ClassWPropsSet, ObjWPropsGet, ObjWPropsSet --
 *
 *	Implementations of the "writableproperties" slot accessors for classes
 *	and instances.
 *
 * ----------------------------------------------------------------------
 */

static void
InstallWritableProps(
    PropertyStorage *props,
    int objc,
    Tcl_Obj *const objv[])
{
    Tcl_Obj *propObj;
    int i, n, created;
    Tcl_HashTable uniqueTable;

    if (props->allWritableCache) {
	Tcl_DecrRefCount(props->allWritableCache);
	props->allWritableCache = NULL;
    }

    for (i=0 ; i<objc ; i++) {
	Tcl_IncrRefCount(objv[i]);
    }
    FOREACH(propObj, props->writable) {
	Tcl_DecrRefCount(propObj);
    }
    if (i != objc) {
	if (objc == 0) {
	    ckfree(props->writable.list);
	} else if (i) {
	    props->writable.list = (Tcl_Obj **)ckrealloc(props->writable.list,
		    sizeof(Tcl_Obj *) * objc);
	} else {
	    props->writable.list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc);
	}
    }
    props->writable.num = 0;
    if (objc > 0) {
	Tcl_InitObjHashTable(&uniqueTable);
	for (i=n=0 ; i<objc ; i++) {
	    Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
	    if (created) {
		props->writable.list[n++] = objv[i];
	    } else {
		Tcl_DecrRefCount(objv[i]);
	    }
	}
	props->writable.num = n;

	/*
	 * Shouldn't be necessary, but maintain num/list invariant.
	 */

	if (n != objc) {
	    props->writable.list = (Tcl_Obj **)ckrealloc(props->writable.list,
		    sizeof(Tcl_Obj *) * n);
	}
	Tcl_DeleteHashTable(&uniqueTable);
    }
}

static int
ClassWPropsGet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *propNameObj;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(propNameObj, oPtr->classPtr->properties.writable) {
	Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ClassWPropsSet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int varc;
    Tcl_Obj **varv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"propertyList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (!oPtr->classPtr) {
	Tcl_SetObjResult(interp, Tcl_NewStringObj(
		"attempt to misuse API", -1));
	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    InstallWritableProps(&oPtr->classPtr->properties, varc, varv);
    BumpGlobalEpoch(interp, oPtr->classPtr);
    return TCL_OK;
}

static int
ObjWPropsGet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    Tcl_Obj *resultObj, *propNameObj;
    int i;

    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		NULL);
	return TCL_ERROR;
    }
    if (oPtr == NULL) {
	return TCL_ERROR;
    }

    resultObj = Tcl_NewObj();
    FOREACH(propNameObj, oPtr->properties.writable) {
	Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
    }
    Tcl_SetObjResult(interp, resultObj);
    return TCL_OK;
}

static int
ObjWPropsSet(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    Tcl_ObjectContext context,
    int objc,
    Tcl_Obj *const *objv)
{
    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
    int varc;
    Tcl_Obj **varv;

    if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
		"propertyList");
	return TCL_ERROR;
    }
    objv += Tcl_ObjectContextSkippedArgs(context);

    if (oPtr == NULL) {
	return TCL_ERROR;
    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
	    &varv) != TCL_OK) {
	return TCL_ERROR;
    }

    InstallWritableProps(&oPtr->properties, varc, varv);
    return TCL_OK;
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

/*
 * tclOODefineCmds.c --
 *
 *	This file contains the implementation of the ::oo-related [info]
 *	subcommands.
 *
 * Copyright © 2006-2011 Donal K. Fellows
 * Copyright © 2006-2019 Donal K. Fellows
 *
 * See the file "license.terms" for information on usage and redistribution of
 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include "tclInt.h"
#include "tclOOInt.h"

static inline Class *	GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void		SortPropList(Tcl_Obj *list);
static Tcl_ObjCmdProc InfoObjectCallCmd;
static Tcl_ObjCmdProc InfoObjectClassCmd;
static Tcl_ObjCmdProc InfoObjectDefnCmd;
static Tcl_ObjCmdProc InfoObjectFiltersCmd;
static Tcl_ObjCmdProc InfoObjectForwardCmd;
static Tcl_ObjCmdProc InfoObjectIdCmd;
static Tcl_ObjCmdProc InfoObjectIsACmd;
static Tcl_ObjCmdProc InfoObjectMethodsCmd;
static Tcl_ObjCmdProc InfoObjectMethodTypeCmd;
static Tcl_ObjCmdProc InfoObjectMixinsCmd;
static Tcl_ObjCmdProc InfoObjectNsCmd;
static Tcl_ObjCmdProc InfoObjectPropCmd;
static Tcl_ObjCmdProc InfoObjectVarsCmd;
static Tcl_ObjCmdProc InfoObjectVariablesCmd;
static Tcl_ObjCmdProc InfoClassCallCmd;
static Tcl_ObjCmdProc InfoClassConstrCmd;
static Tcl_ObjCmdProc InfoClassDefnCmd;
static Tcl_ObjCmdProc InfoClassDefnNsCmd;
static Tcl_ObjCmdProc InfoClassDestrCmd;
static Tcl_ObjCmdProc InfoClassFiltersCmd;
static Tcl_ObjCmdProc InfoClassForwardCmd;
static Tcl_ObjCmdProc InfoClassInstancesCmd;
static Tcl_ObjCmdProc InfoClassMethodsCmd;
static Tcl_ObjCmdProc InfoClassMethodTypeCmd;
static Tcl_ObjCmdProc InfoClassMixinsCmd;
static Tcl_ObjCmdProc InfoClassPropCmd;
static Tcl_ObjCmdProc InfoClassSubsCmd;
static Tcl_ObjCmdProc InfoClassSupersCmd;
static Tcl_ObjCmdProc InfoClassVariablesCmd;

/*
 * List of commands that are used to implement the [info object] subcommands.
 */

static const EnsembleImplMap infoObjectCmds[] = {
    {"call",	   InfoObjectCallCmd,	    TclCompileBasic2ArgCmd, NULL, NULL, 0},
    {"class",	   InfoObjectClassCmd,	    TclCompileInfoObjectClassCmd, NULL, NULL, 0},
    {"creationid", InfoObjectIdCmd,	    TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"definition", InfoObjectDefnCmd,	    TclCompileBasic2ArgCmd, NULL, NULL, 0},
    {"filters",	   InfoObjectFiltersCmd,    TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"forward",	   InfoObjectForwardCmd,    TclCompileBasic2ArgCmd, NULL, NULL, 0},
    {"isa",	   InfoObjectIsACmd,	    TclCompileInfoObjectIsACmd, NULL, NULL, 0},
    {"methods",	   InfoObjectMethodsCmd,    TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
    {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0},
    {"mixins",	   InfoObjectMixinsCmd,	    TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"namespace",  InfoObjectNsCmd,	    TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0},
    {"properties", InfoObjectPropCmd,	    TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
    {"variables",  InfoObjectVariablesCmd,  TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    {"vars",	   InfoObjectVarsCmd,	    TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    {NULL, NULL, NULL, NULL, NULL, 0}
};

/*
 * List of commands that are used to implement the [info class] subcommands.

    {"destructor",   InfoClassDestrCmd,		TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"filters",	     InfoClassFiltersCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"forward",	     InfoClassForwardCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
    {"instances",    InfoClassInstancesCmd,	TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    {"methods",	     InfoClassMethodsCmd,	TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
    {"methodtype",   InfoClassMethodTypeCmd,	TclCompileBasic2ArgCmd, NULL, NULL, 0},
    {"mixins",	     InfoClassMixinsCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"properties",   InfoClassPropCmd,		TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
    {"subclasses",   InfoClassSubsCmd,		TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    {"superclasses", InfoClassSupersCmd,	TclCompileBasic1ArgCmd, NULL, NULL, 0},
    {"variables",    InfoClassVariablesCmd,	TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
    {NULL, NULL, NULL, NULL, NULL, 0}
};

/*

		"cannot construct any call chain", -1));
	return TCL_ERROR;
    }
    Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
    TclOODeleteChain(callPtr);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * InfoClassPropCmd, InfoObjectPropCmd --
 *
 *	Implements [info class properties $clsName ?$option...?] and
 *	[info object properties $objName ?$option...?]
 *
 * ----------------------------------------------------------------------
 */

enum PropOpt {
    PROP_ALL, PROP_READABLE, PROP_WRITABLE
};
static const char *const propOptNames[] = {
    "-all", "-readable", "-writable",
    NULL
};

static int
InfoClassPropCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Class *clsPtr;
    int i, idx, all = 0, writable = 0, allocated = 0;
    Tcl_Obj *result, *propObj;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?");
	return TCL_ERROR;
    }
    clsPtr = GetClassFromObj(interp, objv[1]);
    if (clsPtr == NULL) {
	return TCL_ERROR;
    }
    for (i = 2; i < objc; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
		&idx) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (idx) {
	case PROP_ALL:
	    all = 1;
	    break;
	case PROP_READABLE:
	    writable = 0;
	    break;
	case PROP_WRITABLE:
	    writable = 1;
	    break;
	}
    }

    /*
     * Get the properties.
     */

    if (all) {
	result = TclOOGetAllClassProperties(clsPtr, writable, &allocated);
	if (allocated) {
	    SortPropList(result);
	}
    } else {
	result = Tcl_NewObj();
	if (writable) {
	    FOREACH(propObj, clsPtr->properties.writable) {
		Tcl_ListObjAppendElement(NULL, result, propObj);
	    }
	} else {
	    FOREACH(propObj, clsPtr->properties.readable) {
		Tcl_ListObjAppendElement(NULL, result, propObj);
	    }
	}
	SortPropList(result);
    }
    Tcl_SetObjResult(interp, result);
    return TCL_OK;
}

static int
InfoObjectPropCmd(
    TCL_UNUSED(void *),
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const objv[])
{
    Object *oPtr;
    int i, idx, all = 0, writable = 0, allocated = 0;
    Tcl_Obj *result, *propObj;

    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "objName ?options...?");
	return TCL_ERROR;
    }
    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
    if (oPtr == NULL) {
	return TCL_ERROR;
    }
    for (i = 2; i < objc; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], propOptNames, "option", 0,
		&idx) != TCL_OK) {
	    return TCL_ERROR;
	}
	switch (idx) {
	case PROP_ALL:
	    all = 1;
	    break;
	case PROP_READABLE:
	    writable = 0;
	    break;
	case PROP_WRITABLE:
	    writable = 1;
	    break;
	}
    }

    /*
     * Get the properties.
     */

    if (all) {
	result = TclOOGetAllObjectProperties(oPtr, writable, &allocated);
	if (allocated) {
	    SortPropList(result);
	}
    } else {
	result = Tcl_NewObj();
	if (writable) {
	    FOREACH(propObj, oPtr->properties.writable) {
		Tcl_ListObjAppendElement(NULL, result, propObj);
	    }
	} else {
	    FOREACH(propObj, oPtr->properties.readable) {
		Tcl_ListObjAppendElement(NULL, result, propObj);
	    }
	}
	SortPropList(result);
    }
    Tcl_SetObjResult(interp, result);
    return TCL_OK;
}

/*
 * ----------------------------------------------------------------------
 *
 * SortPropList --
 *	Sort a list of names of properties. Simple support function. Assumes
 *	that the list Tcl_Obj is unshared and doesn't have a string
 *	representation.
 *
 * ----------------------------------------------------------------------
 */

static int
PropNameCompare(
    const void *a,
    const void *b)
{
    Tcl_Obj *first = *(Tcl_Obj **) a;
    Tcl_Obj *second = *(Tcl_Obj **) b;

    return strcmp(Tcl_GetString(first), Tcl_GetString(second));
}

static void
SortPropList(
    Tcl_Obj *list)
{
    int ec;
    Tcl_Obj **ev;

    Tcl_ListObjGetElements(NULL, list, &ec, &ev);
    qsort(ev, ec, sizeof(Tcl_Obj *), PropNameCompare);
}

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

/*
 * These types are needed in function arguments.
 */

typedef LIST_STATIC(Tcl_Obj *) VariableNameList;
typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList;

/*
 * This type is used in various places.
 */

typedef struct {
    LIST_STATIC(Tcl_Obj *) readable;
				/* The readable properties slot. */
    LIST_STATIC(Tcl_Obj *) writable;
				/* The writable properties slot. */
    Tcl_Obj *allReadableCache;	/* The cache of all readable properties
				 * exposed by this object or class (in its
				 * stereotypical instancs). Contains a sorted
				 * unique list if not NULL. */
    Tcl_Obj *allWritableCache;	/* The cache of all writable properties
				 * exposed by this object or class (in its
				 * stereotypical instances). Contains a sorted
				 * unique list if not NULL. */
    int epoch;			/* The epoch that the caches are valid for. */
} PropertyStorage;

/*
 * Now, the definition of what an object actually is.
 */

typedef struct Object {
    struct Foundation *fPtr;	/* The basis for the object system. Putting
				 * this here allows the avoidance of quite a

    Tcl_HashTable *methodsPtr;	/* Object-local Tcl_Obj (method name) to
				 * Method* mapping. */
    LIST_STATIC(struct Class *) mixins;
				/* Classes mixed into this object. */
    LIST_STATIC(Tcl_Obj *) filters;
				/* List of filter names. */
    struct Class *classPtr;	/* This is non-NULL for all classes, and NULL
				 *  for everything else. It points to the class
				 *  structure. */
				 * for everything else. It points to the class
				 * structure. */
    int refCount;		/* Number of strong references to this object.
				 * Note that there may be many more weak
				 * references; this mechanism exists to
				 * avoid Tcl_Preserve. */
    int flags;
    int creationEpoch;		/* Unique value to make comparisons of objects
				 * easier. */

				 * names. For itcl-ng. */
    VariableNameList variables;
    PrivateVariableList privateVariables;
				/* Configurations for the variable resolver
				 * used inside methods. */
    Tcl_Command myclassCommand;	/* Reference to this object's class dispatcher
				 * command. */
    PropertyStorage properties;	/* Information relating to the lists of
				 * properties that this object *claims* to
				 * support. */
} Object;

#define OBJECT_DESTRUCTING	1	/* Indicates that an object is being or has
								 *  been destroyed  */
#define DESTRUCTOR_CALLED 2	/* Indicates that evaluation of destructor script for the
							   object has began */
#define OBJECT_DESTRUCTING 1	/* Indicates that an object is being or has
				 *  been destroyed  */
#define DESTRUCTOR_CALLED 2	/* Indicates that evaluation of destructor
				 * script for the object has began */
#define OO_UNUSED_4	4	/* No longer used.  */
#define ROOT_OBJECT 0x1000	/* Flag to say that this object is the root of
				 * the class hierarchy and should be treated
				 * specially during teardown. */
#define FILTER_HANDLING 0x2000	/* Flag set when the object is processing a
				 * filter; when set, filters are *not*
				 * processed on the object, preventing nasty

				 * class in when those instances are defined
				 * as instances. If NULL, use the value from
				 * the class hierarchy. It's an error at
				 * [oo::objdefine]/[self] call time if this
				 * namespace is defined but doesn't exist; we
				 * also check at setting time but don't check
				 * between times. */
    PropertyStorage properties;	/* Information relating to the lists of
				 * properties that this class *claims* to
				 * support. */
} Class;

/*
 * The foundation of the object system within an interpreter contains
 * references to the key classes and namespaces, together with a few other
 * useful bits and pieces. Probably ought to eventually go in the Interp
 * structure itself.

MODULE_SCOPE int	TclOODefineSlots(Foundation *fPtr);
MODULE_SCOPE void	TclOODeleteChain(CallChain *callPtr);
MODULE_SCOPE void	TclOODeleteChainCache(Tcl_HashTable *tablePtr);
MODULE_SCOPE void	TclOODeleteContext(CallContext *contextPtr);
MODULE_SCOPE void	TclOODeleteDescendants(Tcl_Interp *interp,
			    Object *oPtr);
MODULE_SCOPE void	TclOODelMethodRef(Method *method);
MODULE_SCOPE Tcl_Obj *	TclOOGetAllClassProperties(Class *clsPtr,
			    int writable, int *allocated);
MODULE_SCOPE Tcl_Obj *	TclOOGetAllObjectProperties(Object *oPtr,
			    int writable, int *allocated);
MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
			    Tcl_Obj *methodNameObj, int flags,
			    Object *contextObjPtr, Class *contextClsPtr,
			    Tcl_Obj *cacheInThisObj);
MODULE_SCOPE Tcl_Namespace *TclOOGetDefineContextNamespace(
			    Tcl_Interp *interp, Object *oPtr, int forClass);
MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,

 */

static const char *tclOOSetupScript =
/* !BEGIN!: Do not edit below this line. */
"::namespace eval ::oo {\n"
"\t::namespace path {}\n"
"\tnamespace eval Helpers {\n"
"\t\t::namespace path {}\n"
"\t\tnamespace path {}\n"
"\t\tproc callback {method args} {\n"
"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n"
"\t\t}\n"
"\t\tnamespace export callback\n"
"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n"
"\t\tnamespace export -clear\n"
"\t\trename tmp::callback mymethod\n"

"\t\t\treturn\n"
"\t\t}\n"
"\t\tforeach c [info class superclass $class] {\n"
"\t\t\tset d [DelegateName $c]\n"
"\t\t\tif {![info object isa class $d]} {\n"
"\t\t\t\tcontinue\n"
"\t\t\t}\n"
"\t\t\tdefine $delegate ::oo::define::superclass -append $d\n"
"\t\t\tdefine $delegate ::oo::define::superclass -appendifnew $d\n"
"\t\t}\n"
"\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n"
"\t\tobjdefine $class ::oo::objdefine::mixin -appendifnew $delegate\n"
"\t}\n"
"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n"
"\t\tset originDelegate [DelegateName $originObject]\n"
"\t\tset targetDelegate [DelegateName $targetObject]\n"
"\t\tif {\n"
"\t\t\t[info object isa class $originDelegate]\n"
"\t\t\t&& ![info object isa class $targetDelegate]\n"

"\t\t::namespace export initialise\n"
"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n"
"\t\t::namespace export -clear\n"
"\t\t::rename tmp::initialise initialize\n"
"\t\t::namespace delete tmp\n"
"\t}\n"
"\tdefine Slot {\n"
"\t\tmethod Get {} {\n"
"\t\tmethod Get -unexport {} {\n"
"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
"\t\tmethod Set list {\n"
"\t\tmethod Set -unexport list {\n"
"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n"
"\t\t}\n"
"\t\tmethod Resolve list {\n"
"\t\tmethod Resolve -unexport list {\n"
"\t\t\treturn $list\n"
"\t\t}\n"
"\t\tmethod -set args {\n"
"\t\tmethod -set -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\ttailcall my Set $args\n"
"\t\t}\n"
"\t\tmethod -append args {\n"
"\t\tmethod -append -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
"\t\t}\n"
"\t\tmethod -appendifnew -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\tset args [lmap a $args {\n"
"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n"
"\t\t\t\tif {$a in $current} continue\n"
"\t\t\t\tset a\n"
"\t\t\t}]\n"
"\t\t\ttailcall my Set [list {*}$current {*}$args]\n"
"\t\t}\n"
"\t\tmethod -clear {} {tailcall my Set {}}\n"
"\t\tmethod -prepend args {\n"
"\t\tmethod -clear -export {} {tailcall my Set {}}\n"
"\t\tmethod -prepend -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [list {*}$args {*}$current]\n"
"\t\t}\n"
"\t\tmethod -remove args {\n"
"\t\tmethod -remove -export args {\n"
"\t\t\tset my [namespace which my]\n"
"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n"
"\t\t\tset current [uplevel 1 [list $my Get]]\n"
"\t\t\ttailcall my Set [lmap val $current {\n"
"\t\t\t\tif {$val in $args} continue else {set val}\n"
"\t\t\t}]\n"
"\t\t}\n"
"\t\tforward --default-operation my -append\n"
"\t\tmethod unknown {args} {\n"
"\t\tmethod unknown -unexport {args} {\n"
"\t\t\tset def --default-operation\n"
"\t\t\tif {[llength $args] == 0} {\n"
"\t\t\t\ttailcall my $def\n"
"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n"
"\t\t\t\ttailcall my $def {*}$args\n"
"\t\t\t}\n"
"\t\t\tnext {*}$args\n"
"\t\t}\n"
"\t\texport -set -append -clear -prepend -remove\n"
"\t\tunexport unknown destroy\n"
"\t\tunexport destroy\n"
"\t}\n"
"\tobjdefine define::superclass forward --default-operation my -set\n"
"\tobjdefine define::mixin forward --default-operation my -set\n"
"\tobjdefine objdefine::mixin forward --default-operation my -set\n"
"\tdefine object method <cloned> {originObject} {\n"
"\tdefine object method <cloned> -unexport {originObject} {\n"
"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n"
"\t\t\tset args [info args $p]\n"
"\t\t\tset idx -1\n"
"\t\t\tforeach a $args {\n"
"\t\t\t\tif {[info default $p $a d]} {\n"
"\t\t\t\t\tlset args [incr idx] [list $a $d]\n"
"\t\t\t\t} else {\n"

"\t\t\t\t\tarray set vNew [array get vOrigin]\n"
"\t\t\t\t} else {\n"
"\t\t\t\t\tset vNew $vOrigin\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t}\n"
"\t}\n"
"\tdefine class method <cloned> {originObject} {\n"
"\tdefine class method <cloned> -unexport {originObject} {\n"
"\t\tnext $originObject\n"
"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n"
"\t}\n"
"\tclass create singleton {\n"
"\t\tsuperclass class\n"
"\t\tvariable object\n"
"\t\tunexport create createWithNamespace\n"
"\t\tmethod new args {\n"
"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n"
"\t\t\t\tset object [next {*}$args]\n"
"\t\t\t\t::oo::objdefine $object {\n"
"\t\t\t\t\tmethod destroy {} {\n"
"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n"
"\t\t\t\t\t}\n"
"\t\t\t\t\tmethod <cloned> {originObject} {\n"
"\t\t\t\t\tmethod <cloned> -unexport {originObject} {\n"
"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n"
"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n"
"\t\t\t\t\t}\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\treturn $object\n"
"\t\t}\n"
"\t}\n"
"\tclass create abstract {\n"
"\t\tsuperclass class\n"
"\t\tunexport create createWithNamespace new\n"
"\t}\n"
"\t::namespace eval configuresupport {\n"
"\t\tnamespace path ::tcl\n"
"\t\tproc PropertyImpl {readslot writeslot args} {\n"
"\t\t\tfor {set i 0} {$i < [llength $args]} {incr i} {\n"
"\t\t\t\tset prop [lindex $args $i]\n"
"\t\t\t\tif {[string match \"-*\" $prop]} {\n"
"\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not begin with -\"\n"
"\t\t\t\t}\n"
"\t\t\t\tif {$prop ne [list $prop]} {\n"
"\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must be a simple word\"\n"
"\t\t\t\t}\n"
"\t\t\t\tif {[string first \"::\" $prop] != -1} {\n"
"\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain namespace separators\"\n"
"\t\t\t\t}\n"
"\t\t\t\tif {[string match {*[()]*} $prop]} {\n"
"\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t-errorcode {TCLOO PROPERTY_FORMAT} \\\n"
"\t\t\t\t\t\t\"bad property name \\\"$prop\\\": must not contain parentheses\"\n"
"\t\t\t\t}\n"
"\t\t\t\tset realprop [string cat \"-\" $prop]\n"
"\t\t\t\tset getter [format {::set [my varname %s]} $prop]\n"
"\t\t\t\tset setter [format {::set [my varname %s] $value} $prop]\n"
"\t\t\t\tset kind readwrite\n"
"\t\t\t\twhile {[set next [lindex $args [expr {$i + 1}]]\n"
"\t\t\t\t\t\tstring match \"-*\" $next]} {\n"
"\t\t\t\t\tset arg [lindex $args [incr i 2]]\n"
"\t\t\t\t\tswitch [prefix match -error [list -level 2 -errorcode \\\n"
"\t\t\t\t\t\t\t[list TCL LOOKUP INDEX option $next]] {-get -kind -set} $next] {\n"
"\t\t\t\t\t\t-get {\n"
"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
"\t\t\t\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
"\t\t\t\t\t\t\t\t\t\"missing body to go with -get option\"\n"
"\t\t\t\t\t\t\t}\n"
"\t\t\t\t\t\t\tset getter $arg\n"
"\t\t\t\t\t\t}\n"
"\t\t\t\t\t\t-set {\n"
"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
"\t\t\t\t\t\t\t\treturn -code error -level 2 \\\n"
"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
"\t\t\t\t\t\t\t\t\t\"missing body to go with -set option\"\n"
"\t\t\t\t\t\t\t}\n"
"\t\t\t\t\t\t\tset setter $arg\n"
"\t\t\t\t\t\t}\n"
"\t\t\t\t\t\t-kind {\n"
"\t\t\t\t\t\t\tif {$i >= [llength $args]} {\n"
"\t\t\t\t\t\t\t\treturn -code error -level 2\\\n"
"\t\t\t\t\t\t\t\t\t-errorcode {TCL WRONGARGS} \\\n"
"\t\t\t\t\t\t\t\t\t\"missing kind value to go with -kind option\"\n"
"\t\t\t\t\t\t\t}\n"
"\t\t\t\t\t\t\tset kind [prefix match -message \"kind\" -error [list \\\n"
"\t\t\t\t\t\t\t\t\t-level 2 \\\n"
"\t\t\t\t\t\t\t\t\t-errorcode [list TCL LOOKUP INDEX kind $arg]] {\n"
"\t\t\t\t\t\t\t\treadable readwrite writable\n"
"\t\t\t\t\t\t\t} $arg]\n"
"\t\t\t\t\t\t}\n"
"\t\t\t\t\t}\n"
"\t\t\t\t}\n"
"\t\t\t\tset reader <ReadProp$realprop>\n"
"\t\t\t\tset writer <WriteProp$realprop>\n"
"\t\t\t\tswitch $kind {\n"
"\t\t\t\t\treadable {\n"
"\t\t\t\t\t\tuplevel 2 [list $readslot -append $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list $writeslot -remove $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list method $reader -unexport {} $getter]\n"
"\t\t\t\t\t}\n"
"\t\t\t\t\twritable {\n"
"\t\t\t\t\t\tuplevel 2 [list $readslot -remove $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list $writeslot -append $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list method $writer -unexport {value} $setter]\n"
"\t\t\t\t\t}\n"
"\t\t\t\t\treadwrite {\n"
"\t\t\t\t\t\tuplevel 2 [list $readslot -append $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list $writeslot -append $realprop]\n"
"\t\t\t\t\t\tuplevel 2 [list method $reader -unexport {} $getter]\n"
"\t\t\t\t\t\tuplevel 2 [list method $writer -unexport {value} $setter]\n"
"\t\t\t\t\t}\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t}\n"
"\t\tnamespace eval configurableclass {\n"
"\t\t\t::proc property args {\n"
"\t\t\t\t::oo::configuresupport::PropertyImpl \\\n"
"\t\t\t\t\t::oo::configuresupport::readableproperties \\\n"
"\t\t\t\t\t::oo::configuresupport::writableproperties {*}$args\n"
"\t\t\t}\n"
"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t\t::namespace path ::oo::define\n"
"\t\t\t::namespace export property\n"
"\t\t}\n"
"\t\tnamespace eval configurableobject {\n"
"\t\t\t::proc property args {\n"
"\t\t\t\t::oo::configuresupport::PropertyImpl \\\n"
"\t\t\t\t\t::oo::configuresupport::objreadableproperties \\\n"
"\t\t\t\t\t::oo::configuresupport::objwritableproperties {*}$args\n"
"\t\t\t}\n"
"\t\t\t::proc properties args {::tailcall property {*}$args}\n"
"\t\t\t::namespace path ::oo::objdefine\n"
"\t\t\t::namespace export property\n"
"\t\t}\n"
"\t\tproc ReadAll {object my} {\n"
"\t\t\tset result {}\n"
"\t\t\tforeach prop [info object properties $object -all -readable] {\n"
"\t\t\t\ttry {\n"
"\t\t\t\t\tdict set result $prop [$my <ReadProp$prop>]\n"
"\t\t\t\t} on error {msg opt} {\n"
"\t\t\t\t\tdict set opt -level 2\n"
"\t\t\t\t\treturn -options $opt $msg\n"
"\t\t\t\t} on return {msg opt} {\n"
"\t\t\t\t\tdict incr opt -level 2\n"
"\t\t\t\t\treturn -options $opt $msg\n"
"\t\t\t\t} on break {} {\n"
"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\t\"property getter for $prop did a break\"\n"
"\t\t\t\t} on continue {} {\n"
"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\t\"property getter for $prop did a continue\"\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\treturn $result\n"
"\t\t}\n"
"\t\tproc ReadOne {object my propertyName} {\n"
"\t\t\tset props [info object properties $object -all -readable]\n"
"\t\t\ttry {\n"
"\t\t\t\tset prop [prefix match -message \"property\" $props $propertyName]\n"
"\t\t\t} on error {msg} {\n"
"\t\t\t\tcatch {\n"
"\t\t\t\t\tset wps [info object properties $object -all -writable]\n"
"\t\t\t\t\tset wprop [prefix match $wps $propertyName]\n"
"\t\t\t\t\tset msg \"property \\\"$wprop\\\" is write only\"\n"
"\t\t\t\t}\n"
"\t\t\t\treturn -code error -level 2 -errorcode [list \\\n"
"\t\t\t\t\t\tTCL LOOKUP INDEX property $propertyName] $msg\n"
"\t\t\t}\n"
"\t\t\ttry {\n"
"\t\t\t\tset value [$my <ReadProp$prop>]\n"
"\t\t\t} on error {msg opt} {\n"
"\t\t\t\tdict set opt -level 2\n"
"\t\t\t\treturn -options $opt $msg\n"
"\t\t\t} on return {msg opt} {\n"
"\t\t\t\tdict incr opt -level 2\n"
"\t\t\t\treturn -options $opt $msg\n"
"\t\t\t} on break {} {\n"
"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\"property getter for $prop did a break\"\n"
"\t\t\t} on continue {} {\n"
"\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\"property getter for $prop did a continue\"\n"
"\t\t\t}\n"
"\t\t\treturn $value\n"
"\t\t}\n"
"\t\tproc WriteMany {object my setterMap} {\n"
"\t\t\tset props [info object properties $object -all -writable]\n"
"\t\t\tforeach {prop value} $setterMap {\n"
"\t\t\t\ttry {\n"
"\t\t\t\t\tset prop [prefix match -message \"property\" $props $prop]\n"
"\t\t\t\t} on error {msg} {\n"
"\t\t\t\t\tcatch {\n"
"\t\t\t\t\t\tset rps [info object properties $object -all -readable]\n"
"\t\t\t\t\t\tset rprop [prefix match $rps $prop]\n"
"\t\t\t\t\t\tset msg \"property \\\"$rprop\\\" is read only\"\n"
"\t\t\t\t\t}\n"
"\t\t\t\t\treturn -code error -level 2 -errorcode [list \\\n"
"\t\t\t\t\t\t\tTCL LOOKUP INDEX property $prop] $msg\n"
"\t\t\t\t}\n"
"\t\t\t\ttry {\n"
"\t\t\t\t\t$my <WriteProp$prop> $value\n"
"\t\t\t\t} on error {msg opt} {\n"
"\t\t\t\t\tdict set opt -level 2\n"
"\t\t\t\t\treturn -options $opt $msg\n"
"\t\t\t\t} on return {msg opt} {\n"
"\t\t\t\t\tdict incr opt -level 2\n"
"\t\t\t\t\treturn -options $opt $msg\n"
"\t\t\t\t} on break {} {\n"
"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\t\"property setter for $prop did a break\"\n"
"\t\t\t\t} on continue {} {\n"
"\t\t\t\t\treturn -code error -level 2 -errorcode {TCLOO SHENANIGANS} \\\n"
"\t\t\t\t\t\t\"property setter for $prop did a continue\"\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\treturn\n"
"\t\t}\n"
"\t\t::oo::class create configurable {\n"
"\t\t\tprivate variable my\n"
"\t\t\tmethod configure -export args {\n"
"\t\t\t\t::if {![::info exists my]} {\n"
"\t\t\t\t\t::set my [::namespace which my]\n"
"\t\t\t\t}\n"
"\t\t\t\t::if {[::llength $args] == 0} {\n"
"\t\t\t\t\t::oo::configuresupport::ReadAll [self] $my\n"
"\t\t\t\t} elseif {[::llength $args] == 1} {\n"
"\t\t\t\t\t::oo::configuresupport::ReadOne [self] $my \\\n"
"\t\t\t\t\t\t[::lindex $args 0]\n"
"\t\t\t\t} elseif {[::llength $args] % 2 == 0} {\n"
"\t\t\t\t\t::oo::configuresupport::WriteMany [self] $my $args\n"
"\t\t\t\t} else {\n"
"\t\t\t\t\t::return -code error -errorcode {TCL WRONGARGS} \\\n"
"\t\t\t\t\t\t[::format {wrong # args: should be \"%s\"} \\\n"
"\t\t\t\t\t\t\t\"[self] configure \?-option value ...\?\"]\n"
"\t\t\t\t}\n"
"\t\t\t}\n"
"\t\t\tdefinitionnamespace -instance configurableobject\n"
"\t\t\tdefinitionnamespace -class configurableclass\n"
"\t\t}\n"
"\t}\n"
"\tclass create configurable {\n"
"\t\tsuperclass class\n"
"\t\tconstructor {{definitionScript \"\"}} {\n"
"\t\t\tnext {mixin ::oo::configuresupport::configurable}\n"
"\t\t\tnext $definitionScript\n"
"\t\t}\n"
"\t\tdefinitionnamespace -class configuresupport::configurableclass\n"
"\t}\n"
"}\n"
/* !END!: Do not edit above this line. */
;

#endif /* TCL_OO_SCRIPT_H */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

	foreach initial $initials {
	    lappend x [info object class $initial]
	}
	return $x
    }] {lsort [lsearch -all -not -inline $x *::delegate]}
} -cleanup {
    interp delete $fresh
} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::object ::oo::singleton} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class} {::oo::abstract ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}
} -result {{} {::oo::Slot ::oo::abstract ::oo::class ::oo::configurable ::oo::configuresupport::configurable ::oo::object ::oo::singleton} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable} {::oo::Slot ::oo::class ::oo::configuresupport::configurable} {::oo::abstract ::oo::configurable ::oo::singleton} {} {} {} {} {} ::oo::object ::oo::object ::oo::class ::oo::class ::oo::class}

test oo-2.1 {basic test of OO functionality: constructor} -setup {
    # This is a bit complex because it needs to run in a sub-interp as
    # we're modifying the root object class's constructor
    interp create subinterp
    subinterp eval {
	package require tcl::oo

    while executing
\"info object\""
test oo-16.2 {OO: object introspection} -body {
    info object class NOTANOBJECT
} -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
test oo-16.3 {OO: object introspection} -body {
    info object gorp oo::object
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, creationid, definition, filters, forward, isa, methods, methodtype, mixins, namespace, properties, variables, or vars}
test oo-16.4 {OO: object introspection} -setup {
    oo::class create meta { superclass oo::class }
    [meta create instance1] create instance2
} -body {
    list [list [info object class oo::object] \
	      [info object class oo::class] \
	      [info object class meta] \

} -body {
    info class superclass foo
} -returnCodes 1 -cleanup {
    foo destroy
} -result {"foo" is not a class}
test oo-17.4 {OO: class introspection} -body {
    info class gorp oo::object
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, definitionnamespace, destructor, filters, forward, instances, methods, methodtype, mixins, properties, subclasses, superclasses, or variables}
test oo-17.5 {OO: class introspection} -setup {
    oo::class create testClass
} -body {
    testClass create foo
    testClass create bar
    testClass create spong
    lsort [info class instances testClass]

    set s [SampleSlot new]
}] -body {
    # Method names beginning with "-" are special to slots
    $s -grill q
} -returnCodes error -cleanup [SampleSlotCleanup {
    rename $s {}
}] -result \
    {unknown method "-grill": must be -append, -clear, -prepend, -remove, -set, contents or ops}
    {unknown method "-grill": must be -append, -appendifnew, -clear, -prepend, -remove, -set, contents or ops}

test oo-34.1 {TIP 380: slots - presence} -setup {
    set obj [oo::object new]
    set result {}
} -body {
    oo::define oo::object {
	::lappend ::result [::info object class filter]

    }
    return $result
} -cleanup {
    $obj destroy
} -result {::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot}
test oo-34.2 {TIP 380: slots - presence} {
    lsort [info class instances oo::Slot]
} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
} {::oo::configuresupport::objreadableproperties ::oo::configuresupport::objwritableproperties ::oo::configuresupport::readableproperties ::oo::configuresupport::writableproperties ::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
proc getMethods obj {
    list [lsort [info object methods $obj -all]] \
	[lsort [info object methods $obj -private]]
}
test oo-34.3 {TIP 380: slots - presence} {
    getMethods oo::define::filter
} {{-append -clear -prepend -remove -set} {Get Set}}
} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.4 {TIP 380: slots - presence} {
    getMethods oo::define::mixin
} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.5 {TIP 380: slots - presence} {
    getMethods oo::define::superclass
} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.6 {TIP 380: slots - presence} {
    getMethods oo::define::variable
} {{-append -clear -prepend -remove -set} {Get Set}}
} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.7 {TIP 380: slots - presence} {
    getMethods oo::objdefine::filter
} {{-append -clear -prepend -remove -set} {Get Set}}
} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.8 {TIP 380: slots - presence} {
    getMethods oo::objdefine::mixin
} {{-append -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
} {{-append -appendifnew -clear -prepend -remove -set} {--default-operation Get Resolve Set}}
test oo-34.9 {TIP 380: slots - presence} {
    getMethods oo::objdefine::variable
} {{-append -clear -prepend -remove -set} {Get Set}}
} {{-append -appendifnew -clear -prepend -remove -set} {Get Set}}
test oo-34.10 {TIP 516: slots - resolution} -setup {
    oo::class create parent
    set result {}
    oo::class create 516a { superclass parent }
    oo::class create 516b { superclass parent }
    oo::class create 516c { superclass parent }
    namespace eval 516test {

# This file contains a collection of tests for Tcl's built-in object system,
# specifically the parts that support configurable properties on objects.
# Sourcing this file into Tcl runs the tests and generates output for errors.
# No output means no errors were found.
#
# Copyright (c) 2019-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.

package require tcl::oo 1.0.3
package require tcltest 2
if {"::tcltest" in [namespace children]} {
    namespace import -force ::tcltest::*
}

test ooProp-1.1 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    lappend result [info class properties c] [info class properties c -writable]
    oo::define c ::oo::configuresupport::readableproperties -set a b c
    lappend result [info class properties c] [info class properties c -writable]
    oo::define c ::oo::configuresupport::readableproperties -set f e d
    lappend result [info class properties c] [info class properties c -writable]
    oo::define c ::oo::configuresupport::readableproperties -set a a a
    lappend result [info class properties c] [info class properties c -writable]
    oo::define c ::oo::configuresupport::readableproperties -set
    lappend result [info class properties c] [info class properties c -writable]
} -cleanup {
    parent destroy
} -result {{} {} {a b c} {} {d e f} {} a {} {} {}}
test ooProp-1.2 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    lappend result [info class properties c -all] [info class properties c -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set a b c
    lappend result [info class properties c -all] [info class properties c -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set f e d
    lappend result [info class properties c -all] [info class properties c -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set a a a
    lappend result [info class properties c -all] [info class properties c -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set
    lappend result [info class properties c -all] [info class properties c -writable -all]
} -cleanup {
    parent destroy
} -result {{} {} {a b c} {} {d e f} {} a {} {} {}}
test ooProp-1.3 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    lappend result [info class properties c] [info class properties c -writable]
    oo::define c ::oo::configuresupport::writableproperties -set a b c
    lappend result [info class properties c] [info class properties c -writable]
    oo::define c ::oo::configuresupport::writableproperties -set f e d
    lappend result [info class properties c] [info class properties c -writable]
    oo::define c ::oo::configuresupport::writableproperties -set a a a
    lappend result [info class properties c] [info class properties c -writable]
    oo::define c ::oo::configuresupport::writableproperties -set
    lappend result [info class properties c] [info class properties c -writable]
} -cleanup {
    parent destroy
} -result {{} {} {} {a b c} {} {d e f} {} a {} {}}
test ooProp-1.4 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    lappend result [info class properties c -all] [info class properties c -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set a b c
    lappend result [info class properties c -all] [info class properties c -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set f e d
    lappend result [info class properties c -all] [info class properties c -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set a a a
    lappend result [info class properties c -all] [info class properties c -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set
    lappend result [info class properties c -all] [info class properties c -writable -all]
} -cleanup {
    parent destroy
} -result {{} {} {} {a b c} {} {d e f} {} a {} {}}
test ooProp-1.5 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    oo::class create d {superclass c}
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set a b c
    oo::define d ::oo::configuresupport::readableproperties -set x y z
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set f e d
    oo::define d ::oo::configuresupport::readableproperties -set r p q
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set a a h
    oo::define d ::oo::configuresupport::readableproperties -set g h g
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define d ::oo::configuresupport::readableproperties -set
    lappend result [info class properties d -all] [info class properties d -writable -all]
} -cleanup {
    parent destroy
} -result {{} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {} {}}
test ooProp-1.6 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    oo::class create d {superclass c}
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set a b c
    oo::define d ::oo::configuresupport::writableproperties -set x y z
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set f e d
    oo::define d ::oo::configuresupport::writableproperties -set r p q
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set a a h
    oo::define d ::oo::configuresupport::writableproperties -set g h g
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set
    lappend result [info class properties d -all] [info class properties d -writable -all]
    oo::define d ::oo::configuresupport::writableproperties -set
    lappend result [info class properties d -all] [info class properties d -writable -all]
} -cleanup {
    parent destroy
} -result {{} {} {} {a b c x y z} {} {d e f p q r} {} {a g h} {} {g h} {} {}}
test ooProp-1.7 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    c create o
    lappend result [info object properties o] [info object properties o -writable]
    oo::objdefine o ::oo::configuresupport::objreadableproperties -set a b c
    lappend result [info object properties o] [info object properties o -writable]
    oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d
    lappend result [info object properties o] [info object properties o -writable]
    oo::objdefine o ::oo::configuresupport::objreadableproperties -set a a h
    lappend result [info object properties o] [info object properties o -writable]
    oo::objdefine o ::oo::configuresupport::objreadableproperties -set
    lappend result [info object properties o] [info object properties o -writable]
} -cleanup {
    parent destroy
} -result {{} {} {a b c} {} {d e f} {} {a h} {} {} {}}
test ooProp-1.8 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    c create o
    lappend result [info object properties o] [info object properties o -writable]
    oo::objdefine o ::oo::configuresupport::objwritableproperties -set a b c
    lappend result [info object properties o] [info object properties o -writable]
    oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d
    lappend result [info object properties o] [info object properties o -writable]
    oo::objdefine o ::oo::configuresupport::objwritableproperties -set a a h
    lappend result [info object properties o] [info object properties o -writable]
    oo::objdefine o ::oo::configuresupport::objwritableproperties -set
    lappend result [info object properties o] [info object properties o -writable]
} -cleanup {
    parent destroy
} -result {{} {} {} {a b c} {} {d e f} {} {a h} {} {}}
test ooProp-1.9 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    oo::class create d {superclass c}
    d create o
    lappend result [info object properties o -all] [info object properties o -writable -all]
    oo::define c ::oo::configuresupport::readableproperties -set a b
    oo::define d ::oo::configuresupport::readableproperties -set c d
    oo::objdefine o ::oo::configuresupport::objreadableproperties -set e f
    lappend result [info object properties o -all] [info object properties o -writable -all]
    oo::objdefine o ::oo::configuresupport::objreadableproperties -set f e d b e
    lappend result [info object properties o -all] [info object properties o -writable -all]
} -cleanup {
    parent destroy
} -result {{} {} {a b c d e f} {} {a b c d e f} {}}
test ooProp-1.10 {TIP 558: properties: core support} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::class create c {superclass parent}
    oo::class create d {superclass c}
    d create o
    lappend result [info object properties o -all] [info object properties o -writable -all]
    oo::define c ::oo::configuresupport::writableproperties -set a b
    oo::define d ::oo::configuresupport::writableproperties -set c d
    oo::objdefine o ::oo::configuresupport::objwritableproperties -set e f
    lappend result [info object properties o -all] [info object properties o -writable -all]
    oo::objdefine o ::oo::configuresupport::objwritableproperties -set f e d b e
    lappend result [info object properties o -all] [info object properties o -writable -all]
} -cleanup {
    parent destroy
} -result {{} {} {} {a b c d e f} {} {a b c d e f}}
test ooProp-1.11 {TIP 558: properties: core support cache} -setup {
    oo::class create parent
    unset -nocomplain result
} -body {
    oo::class create m {
	superclass parent
	::oo::configuresupport::readableproperties -set a
	::oo::configuresupport::writableproperties -set c
    }
    oo::class create c {
	superclass parent
	::oo::configuresupport::readableproperties -set b
	::oo::configuresupport::writableproperties -set d
    }
    c create o
    lappend result [info object properties o -all -readable] \
	[info object properties o -all -writable]
    oo::objdefine o mixin m
    lappend result [info object properties o -all -readable] \
	[info object properties o -all -writable]
} -cleanup {
    parent destroy
} -result {b d {a b} {c d}}

test ooProp-2.1 {TIP 558: properties: configurable class system} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::configurable create Point {
	superclass parent
	property x y
        constructor args {
            my configure -x 0 -y 0 {*}$args
        }
        variable x y
        method report {} {
            lappend ::result "x=$x, y=$y"
        }
    }
    set pt [Point new -x 3]
    $pt report
    $pt configure -y 4
    $pt report
    lappend result [$pt configure -x],[$pt configure -y] [$pt configure]
} -cleanup {
    parent destroy
} -result {{x=3, y=0} {x=3, y=4} 3,4 {-x 3 -y 4}}
test ooProp-2.2 {TIP 558: properties: configurable class system} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x y
        constructor args {
            my configure -x 0 -y 0 {*}$args
        }
    }
    oo::configurable create 3DPoint {
	superclass Point
	property z
	constructor args {
	    next -z 0 {*}$args
	}
    }
    set pt [3DPoint new -x 3 -y 4 -z 5]
    list [$pt configure -x],[$pt configure -y],[$pt configure -z] \
	[$pt configure]
} -cleanup {
    parent destroy
} -result {3,4,5 {-x 3 -y 4 -z 5}}
test ooProp-2.3 {TIP 558: properties: configurable class system} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x y
        constructor args {
            my configure -x 0 -y 0 {*}$args
        }
    }
    set pt [Point new -x 3 -y 4]
    oo::objdefine $pt property z
    $pt configure -z 5
    list [$pt configure -x],[$pt configure -y],[$pt configure -z] \
	[$pt configure]
} -cleanup {
    parent destroy
} -result {3,4,5 {-x 3 -y 4 -z 5}}
test ooProp-2.4 {TIP 558: properties: configurable class system} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x y
        constructor args {
            my configure -x 0 -y 0 {*}$args
        }
    }
    [Point new] configure gorp
} -returnCodes error -cleanup {
    parent destroy
} -result {bad property "gorp": must be -x or -y}
test ooProp-2.5 {TIP 558: properties: configurable class system} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x y
        constructor args {
            my configure -x 0 -y 0 {*}$args
        }
    }
    oo::configurable create 3DPoint {
	superclass Point
	property z
	constructor args {
	    next -z 0 {*}$args
	}
    }
    [3DPoint new] configure gorp
} -returnCodes error -cleanup {
    parent destroy
} -result {bad property "gorp": must be -x, -y, or -z}
test ooProp-2.6 {TIP 558: properties: configurable class system} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x y
        constructor args {
            my configure -x 0 -y 0 {*}$args
        }
    }
    [Point create p] configure -x 1 -y
} -returnCodes error -cleanup {
    parent destroy
} -result {wrong # args: should be "::p configure ?-option value ...?"}
test ooProp-2.7 {TIP 558: properties: configurable class system} -setup {
    oo::class create parent
    unset -nocomplain msg
} -body {
    oo::configurable create Point {
	superclass parent
	property x y -kind writable
        constructor args {
            my configure -x 0 -y 0 {*}$args
        }
    }
    Point create p
    list [p configure -y ok] [catch {p configure -y} msg] $msg
} -cleanup {
    parent destroy
} -result {{} 1 {property "-y" is write only}}
test ooProp-2.8 {TIP 558: properties: configurable class system} -setup {
    oo::class create parent
    unset -nocomplain msg
} -body {
    oo::configurable create Point {
	superclass parent
	property x y -kind readable
        constructor args {
            my configure -x 0 {*}$args
	    variable y 123
        }
    }
    Point create p
    list [p configure] [p configure -y] [catch {p configure -y foo} msg] $msg
} -cleanup {
    parent destroy
} -result {{-x 0 -y 123} 123 1 {property "-y" is read only}}

test ooProp-3.1 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	variable xyz
	property x -get {
	    global result
	    lappend result "get"
	    return [lrepeat 3 $xyz]
	} -set {
	    global result
	    lappend result [list set $value]
	    set xyz [expr {$value * 3}]
	}
    }
    Point create pt
    pt configure -x 5
    lappend result >[pt configure -x]<
} -cleanup {
    parent destroy
} -result {{set 5} get {>15 15 15<}}
test ooProp-3.2 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
    unset -nocomplain result
    set result {}
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	variable xyz
	property x -get {
	    global result
	    lappend result "get"
	    return [lrepeat 3 $xyz]
	} -set {
	    global result
	    lappend result [list set $value]
	    set xyz [expr {$value * 3}]
	} y -kind readable -get {return $xyz}
    }
    Point create pt
    pt configure -x 5
    lappend result >[pt configure -x]< [pt configure -y]
} -cleanup {
    parent destroy
} -result {{set 5} get {>15 15 15<} 15}
test ooProp-3.3 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	variable xyz
	property -x -get {return $xyz}
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {bad property name "-x": must not begin with -}
test ooProp-3.4 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	property "x y"
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {bad property name "x y": must be a simple word}
test ooProp-3.5 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	property ::x
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {bad property name "::x": must not contain namespace separators}
test ooProp-3.6 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	property x(
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {bad property name "x(": must not contain parentheses}
test ooProp-3.7 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	property x)
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {bad property name "x)": must not contain parentheses}
test ooProp-3.8 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	property x -get
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {missing body to go with -get option}
test ooProp-3.9 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	property x -set
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {missing body to go with -set option}
test ooProp-3.10 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	property x -kind
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {missing kind value to go with -kind option}
test ooProp-3.11 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {superclass parent}
    oo::define Point {
	property x -get {} -set
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {missing body to go with -set option}
test ooProp-3.12 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -get {} -get {return ok}
    }
    [Point new] configure -x
} -cleanup {
    parent destroy
} -result ok
test ooProp-3.13 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -kind gorp
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {bad kind "gorp": must be readable, readwrite, or writable}
test ooProp-3.14 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -k reada -g {return ok}
    }
    [Point new] configure -x
} -cleanup {
    parent destroy
} -result ok
test ooProp-3.15 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property {*}{
	    x -kind writable
	    y -get {return ok}
	}
    }
    [Point new] configure -y
} -cleanup {
    parent destroy
} -result ok
test ooProp-3.16 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
    unset -nocomplain msg
} -body {
    oo::configurable create Point {
	superclass parent
	variable xy
	property x -kind readable -get {return $xy}
	property x -kind writable -set {set xy $value}
    }
    Point create pt
    list [catch {
	pt configure -x ok
    } msg] $msg [catch {
	pt configure -x
    } msg] $msg [catch {
	pt configure -y 1
    } msg] $msg
} -cleanup {
    parent destroy
} -result {0 {} 1 {property "-x" is write only} 1 {bad property "-y": must be -x}}
test ooProp-3.17 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -get {return -code break}
    }
    while 1 {
	[Point new] configure -x
	break
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {property getter for -x did a break}
test ooProp-3.18 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -get {return -code break}
    }
    while 1 {
	[Point new] configure
	break
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {property getter for -x did a break}
test ooProp-3.19 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -get {error "boo"}
    }
    while 1 {
	[Point new] configure -x
	break
    }
} -returnCodes error -cleanup {
    parent destroy
} -result boo
test ooProp-3.20 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -get {error "boo"}
    }
    while 1 {
	[Point new] configure
	break
    }
} -returnCodes error -cleanup {
    parent destroy
} -result boo
test ooProp-3.21 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -get {return -code continue}
    }
    while 1 {
	[Point new] configure -x
	break
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {property getter for -x did a continue}
test ooProp-3.22 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -get {return -level 2 ok}
    }
    apply {{} {
	[Point new] configure
	return bad
    }}
} -cleanup {
    parent destroy
} -result ok
test ooProp-3.23 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -get {return -level 2 ok}
    }
    apply {{} {
	[Point new] configure -x
	return bad
    }}
} -cleanup {
    parent destroy
} -result ok
test ooProp-3.24 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -set {return -code break}
    }
    while 1 {
	[Point new] configure -x gorp
	break
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {property setter for -x did a break}
test ooProp-3.25 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -set {return -code continue}
    }
    while 1 {
	[Point new] configure -x gorp
	break
    }
} -returnCodes error -cleanup {
    parent destroy
} -result {property setter for -x did a continue}
test ooProp-3.26 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -set {error "boo"}
    }
    while 1 {
	[Point new] configure -x gorp
	break
    }
} -returnCodes error -cleanup {
    parent destroy
} -result boo
test ooProp-3.27 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	property x -set {return -level 2 ok}
    }
    apply {{} {
	[Point new] configure -x gorp
	return bad
    }}
} -cleanup {
    parent destroy
} -result ok
test ooProp-3.28 {TIP 558: properties: declaration semantics} -setup {
    oo::class create parent
} -body {
    oo::configurable create Point {
	superclass parent
	private property var
    }
    Point create pt
    pt configure -var ok
    pt configure -var
} -cleanup {
    parent destroy
} -result ok

test ooProp-4.1 {TIP 558: properties: error details} -setup {
    oo::class create parent
    unset -nocomplain msg opt
} -body {
    oo::configurable create Point {superclass parent}
    list [catch {oo::define Point {property -x}} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {bad property name "-x": must not begin with -
    while executing
"property -x"
    (in definition script for class "::Point" line 1)
    invoked from within
"oo::define Point {property -x}"} {TCLOO PROPERTY_FORMAT}}
test ooProp-4.2 {TIP 558: properties: error details} -setup {
    oo::class create parent
    unset -nocomplain msg opt
} -body {
    oo::configurable create Point {superclass parent}
    list [catch {oo::define Point {property x -get}} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {missing body to go with -get option
    while executing
"property x -get"
    (in definition script for class "::Point" line 1)
    invoked from within
"oo::define Point {property x -get}"} {TCL WRONGARGS}}
test ooProp-4.3 {TIP 558: properties: error details} -setup {
    oo::class create parent
    unset -nocomplain msg opt
} -body {
    oo::configurable create Point {superclass parent}
    list [catch {oo::define Point {property x -set}} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {missing body to go with -set option
    while executing
"property x -set"
    (in definition script for class "::Point" line 1)
    invoked from within
"oo::define Point {property x -set}"} {TCL WRONGARGS}}
test ooProp-4.4 {TIP 558: properties: error details} -setup {
    oo::class create parent
    unset -nocomplain msg opt
} -body {
    oo::configurable create Point {superclass parent}
    list [catch {oo::define Point {property x -kind}} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {missing kind value to go with -kind option
    while executing
"property x -kind"
    (in definition script for class "::Point" line 1)
    invoked from within
"oo::define Point {property x -kind}"} {TCL WRONGARGS}}
test ooProp-4.5 {TIP 558: properties: error details} -setup {
    oo::class create parent
    unset -nocomplain msg opt
} -body {
    oo::configurable create Point {superclass parent}
    list [catch {oo::define Point {property x -kind gorp}} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {bad kind "gorp": must be readable, readwrite, or writable
    while executing
"property x -kind gorp"
    (in definition script for class "::Point" line 1)
    invoked from within
"oo::define Point {property x -kind gorp}"} {TCL LOOKUP INDEX kind gorp}}
test ooProp-4.6 {TIP 558: properties: error details} -setup {
    oo::class create parent
    unset -nocomplain msg opt
} -body {
    oo::configurable create Point {superclass parent}
    list [catch {oo::define Point {property x -gorp}} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {bad option "-gorp": must be -get, -kind, or -set
    while executing
"property x -gorp"
    (in definition script for class "::Point" line 1)
    invoked from within
"oo::define Point {property x -gorp}"} {TCL LOOKUP INDEX option -gorp}}
test ooProp-4.7 {TIP 558: properties: error details} -setup {
    oo::class create parent
    unset -nocomplain msg opt
} -body {
    oo::configurable create Point {
	superclass parent
	property x
    }
    Point create pt
    list [catch {pt configure -gorp} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {bad property "-gorp": must be -x
    while executing
"pt configure -gorp"} {TCL LOOKUP INDEX property -gorp}}
test ooProp-4.8 {TIP 558: properties: error details} -setup {
    oo::class create parent
    unset -nocomplain msg opt
} -body {
    oo::configurable create Point {
	superclass parent
	property x
    }
    Point create pt
    list [catch {pt configure -gorp blarg} msg opt] \
	[dict get $opt -errorinfo] [dict get $opt -errorcode]
} -cleanup {
    parent destroy
} -result {1 {bad property "-gorp": must be -x
    while executing
"pt configure -gorp blarg"} {TCL LOOKUP INDEX property -gorp}}

cleanupTests
return

# Local Variables:
# mode: tcl
# End:

# tclOOScript.h --
#
# 	This file contains support scripts for TclOO. They are defined here so
# 	that the code can be definitely run even in safe interpreters; TclOO's
# 	core setup is safe.
#
# Copyright © 2012-2018 Donal K. Fellows
# Copyright © 2012-2019 Donal K. Fellows
# Copyright © 2013 Andreas Kupries
# Copyright © 2017 Gerald Lester
#
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.

::namespace eval ::oo {
    ::namespace path {}

    #
    # Commands that are made available to objects by default.
    #
    namespace eval Helpers {
	::namespace path {}
	namespace path {}

	# ------------------------------------------------------------------
	#
	# callback, mymethod --
	#
	#	Create a script prefix that calls a method on the current
	#	object. Same operation, two names.

	    return
	}
	foreach c [info class superclass $class] {
	    set d [DelegateName $c]
	    if {![info object isa class $d]} {
		continue
	    }
	    define $delegate ::oo::define::superclass -append $d
	    define $delegate ::oo::define::superclass -appendifnew $d
	}
	objdefine $class ::oo::objdefine::mixin -append $delegate
	objdefine $class ::oo::objdefine::mixin -appendifnew $delegate
    }

    # ----------------------------------------------------------------------
    #
    # UpdateClassDelegatesAfterClone --
    #
    #	Support code that is like [MixinClassDelegates] except for when a

	#
	#	Basic slot getter. Retrieves the contents of the slot.
	#	Particular slots must provide concrete non-erroring
	#	implementation.
	#
	# ------------------------------------------------------------------

	method Get {} {
	method Get -unexport {} {
	    return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
	}

	# ------------------------------------------------------------------
	#
	# Slot Set --
	#
	#	Basic slot setter. Sets the contents of the slot.  Particular
	#	slots must provide concrete non-erroring implementation.
	#
	# ------------------------------------------------------------------

	method Set list {
	method Set -unexport list {
	    return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented"
	}

	# ------------------------------------------------------------------
	#
	# Slot Resolve --
	#
	#	Helper that lets a slot convert a list of arguments of a
	#	particular type to their canonical forms. Defaults to doing
	#	nothing (suitable for simple strings).
	#
	# ------------------------------------------------------------------

	method Resolve list {
	method Resolve -unexport list {
	    return $list
	}

	# ------------------------------------------------------------------
	#
	# Slot -set, -append, -clear, --default-operation --
	#
	#	Standard public slot operations. If a slot can't figure out
	#	what method to call directly, it uses --default-operation.
	#
	# ------------------------------------------------------------------

	method -set args {
	method -set -export args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    tailcall my Set $args
	}
	method -append args {
	method -append -export args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    set current [uplevel 1 [list $my Get]]
	    tailcall my Set [list {*}$current {*}$args]
	}
	method -appendifnew -export args {
	    set my [namespace which my]
	    set current [uplevel 1 [list $my Get]]
	    foreach a $args {
		set a [uplevel 1 [list $my Resolve $a]]
		if {$a ni $current} {
		    lappend current $a
		}
	    }
	    tailcall my Set $current
	}
	method -clear {} {tailcall my Set {}}
	method -prepend args {
	method -clear -export {} {tailcall my Set {}}
	method -prepend -export args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    set current [uplevel 1 [list $my Get]]
	    tailcall my Set [list {*}$args {*}$current]
	}
	method -remove args {
	method -remove -export args {
	    set my [namespace which my]
	    set args [lmap a $args {uplevel 1 [list $my Resolve $a]}]
	    set current [uplevel 1 [list $my Get]]
	    tailcall my Set [lmap val $current {
		if {$val in $args} continue else {set val}
	    }]
	}

	# Default handling
	forward --default-operation my -append
	method unknown {args} {
	method unknown -unexport {args} {
	    set def --default-operation
	    if {[llength $args] == 0} {
		tailcall my $def
	    } elseif {![string match -* [lindex $args 0]]} {
		tailcall my $def {*}$args
	    }
	    next {*}$args
	}

	# Set up what is exported and what isn't
	# Hide destroy
	export -set -append -clear -prepend -remove
	unexport unknown destroy
	unexport destroy
    }

    # Set the default operation differently for these slots
    objdefine define::superclass forward --default-operation my -set
    objdefine define::mixin forward --default-operation my -set
    objdefine objdefine::mixin forward --default-operation my -set

    # ----------------------------------------------------------------------
    #
    # oo::object <cloned> --
    #
    #	Handler for cloning objects that clones basic bits (only!) of the
    #	object's namespace. Non-procedures, traces, sub-namespaces, etc. need
    #	more complex (and class-specific) handling.
    #
    # ----------------------------------------------------------------------

    define object method <cloned> {originObject} {
    define object method <cloned> -unexport {originObject} {
	# Copy over the procedures from the original namespace
	foreach p [info procs [info object namespace $originObject]::*] {
	    set args [info args $p]
	    set idx -1
	    foreach a $args {
		if {[info default $p $a d]} {
		    lset args [incr idx] [list $a $d]

    #
    # oo::class <cloned> --
    #
    #	Handler for cloning classes, which fixes up the delegates.
    #
    # ----------------------------------------------------------------------

    define class method <cloned> {originObject} {
    define class method <cloned> -unexport {originObject} {
	next $originObject
	# Rebuild the class inheritance delegation class
	::oo::UpdateClassDelegatesAfterClone $originObject [self]
    }

    # ----------------------------------------------------------------------
    #

	    if {![info exists object] || ![info object isa object $object]} {
		set object [next {*}$args]
		::oo::objdefine $object {
		    method destroy {} {
			::return -code error -errorcode {TCLOO SINGLETON} \
			    "may not destroy a singleton object"
		    }
		    method <cloned> {originObject} {
		    method <cloned> -unexport {originObject} {
			::return -code error -errorcode {TCLOO SINGLETON} \
			    "may not clone a singleton object"
		    }
		}
	    }
	    return $object
	}

    #
    # ----------------------------------------------------------------------

    class create abstract {
	superclass class
	unexport create createWithNamespace new
    }

    # ----------------------------------------------------------------------
    #
    # oo::configuresupport --
    #
    #	Namespace that holds all the implementation details of TIP #558.
    #	Also includes the commands:
    #
    #	 * readableproperties
    #	 * writableproperties
    #	 * objreadableproperties
    #	 * objwritableproperties
    #
    #	Those are all slot implementations that provide access to the C layer
    #	of property support (i.e., very fast cached lookup of property names).
    #
    # ----------------------------------------------------------------------

    ::namespace eval configuresupport {
	namespace path ::tcl

	# ------------------------------------------------------------------
	#
	# oo::configuresupport --
	#
	#	A metaclass that is used to make classes that can be configured.
	#
	# ------------------------------------------------------------------

	proc PropertyImpl {readslot writeslot args} {
	    for {set i 0} {$i < [llength $args]} {incr i} {
		# Parse the property name
		set prop [lindex $args $i]
		if {[string match "-*" $prop]} {
		    return -code error -level 2 \
			-errorcode {TCLOO PROPERTY_FORMAT} \
			"bad property name \"$prop\": must not begin with -"
		}
		if {$prop ne [list $prop]} {
		    return -code error -level 2 \
			-errorcode {TCLOO PROPERTY_FORMAT} \
			"bad property name \"$prop\": must be a simple word"
		}
		if {[string first "::" $prop] != -1} {
		    return -code error -level 2 \
			-errorcode {TCLOO PROPERTY_FORMAT} \
			"bad property name \"$prop\": must not contain namespace separators"
		}
		if {[string match {*[()]*} $prop]} {
		    return -code error -level 2 \
			-errorcode {TCLOO PROPERTY_FORMAT} \
			"bad property name \"$prop\": must not contain parentheses"
		}
		set realprop [string cat "-" $prop]
		set getter [format {::set [my varname %s]} $prop]
		set setter [format {::set [my varname %s] $value} $prop]
		set kind readwrite

		# Parse the extra options
		while {[set next [lindex $args [expr {$i + 1}]]
			string match "-*" $next]} {
		    set arg [lindex $args [incr i 2]]
		    switch [prefix match -error [list -level 2 -errorcode \
			    [list TCL LOOKUP INDEX option $next]] {-get -kind -set} $next] {
			-get {
			    if {$i >= [llength $args]} {
				return -code error -level 2 \
				    -errorcode {TCL WRONGARGS} \
				    "missing body to go with -get option"
			    }
			    set getter $arg
			}
			-set {
			    if {$i >= [llength $args]} {
				return -code error -level 2 \
				    -errorcode {TCL WRONGARGS} \
				    "missing body to go with -set option"
			    }
			    set setter $arg
			}
			-kind {
			    if {$i >= [llength $args]} {
				return -code error -level 2\
				    -errorcode {TCL WRONGARGS} \
				    "missing kind value to go with -kind option"
			    }
			    set kind [prefix match -message "kind" -error [list \
				    -level 2 \
				    -errorcode [list TCL LOOKUP INDEX kind $arg]] {
				readable readwrite writable
			    } $arg]
			}
		    }
		}

		# Install the option
		set reader <ReadProp$realprop>
		set writer <WriteProp$realprop>
		switch $kind {
		    readable {
			uplevel 2 [list $readslot -append $realprop]
			uplevel 2 [list $writeslot -remove $realprop]
			uplevel 2 [list method $reader -unexport {} $getter]
		    }
		    writable {
			uplevel 2 [list $readslot -remove $realprop]
			uplevel 2 [list $writeslot -append $realprop]
			uplevel 2 [list method $writer -unexport {value} $setter]
		    }
		    readwrite {
			uplevel 2 [list $readslot -append $realprop]
			uplevel 2 [list $writeslot -append $realprop]
			uplevel 2 [list method $reader -unexport {} $getter]
			uplevel 2 [list method $writer -unexport {value} $setter]
		    }
		}
	    }
	}

	# ------------------------------------------------------------------
	#
	# oo::configuresupport::configurableclass,
	# oo::configuresupport::configurableobject --
	#
	#	Namespaces used as implementation vectors for oo::define and
	#	oo::objdefine when the class/instance is configurable.
	#
	# ------------------------------------------------------------------

	namespace eval configurableclass {
	    ::proc property args {
		::oo::configuresupport::PropertyImpl \
		    ::oo::configuresupport::readableproperties \
		    ::oo::configuresupport::writableproperties {*}$args
	    }
	    # Plural alias just in case; deliberately NOT documented!
	    ::proc properties args {::tailcall property {*}$args}
	    ::namespace path ::oo::define
	    ::namespace export property
	}

	namespace eval configurableobject {
	    ::proc property args {
		::oo::configuresupport::PropertyImpl \
		    ::oo::configuresupport::objreadableproperties \
		    ::oo::configuresupport::objwritableproperties {*}$args
	    }
	    # Plural alias just in case; deliberately NOT documented!
	    ::proc properties args {::tailcall property {*}$args}
	    ::namespace path ::oo::objdefine
	    ::namespace export property
	}

	# ------------------------------------------------------------------
	#
	# oo::configuresupport::ReadAll --
	#
	#	The implementation of [$o configure] with no extra arguments.
	#
	# ------------------------------------------------------------------

	proc ReadAll {object my} {
	    set result {}
	    foreach prop [info object properties $object -all -readable] {
		try {
		    dict set result $prop [$my <ReadProp$prop>]
		} on error {msg opt} {
		    dict set opt -level 2
		    return -options $opt $msg
		} on return {msg opt} {
		    dict incr opt -level 2
		    return -options $opt $msg
		} on break {} {
		    return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
			"property getter for $prop did a break"
		} on continue {} {
		    return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
			"property getter for $prop did a continue"
		}
	    }
	    return $result
	}

	# ------------------------------------------------------------------
	#
	# oo::configuresupport::ReadOne --
	#
	#	The implementation of [$o configure -prop] with that single
	#	extra argument.
	#
	# ------------------------------------------------------------------

	proc ReadOne {object my propertyName} {
	    set props [info object properties $object -all -readable]
	    try {
		set prop [prefix match -message "property" $props $propertyName]
	    } on error {msg} {
		catch {
		    set wps [info object properties $object -all -writable]
		    set wprop [prefix match $wps $propertyName]
		    set msg "property \"$wprop\" is write only"
		}
		return -code error -level 2 -errorcode [list \
			TCL LOOKUP INDEX property $propertyName] $msg
	    }
	    try {
		set value [$my <ReadProp$prop>]
	    } on error {msg opt} {
		dict set opt -level 2
		return -options $opt $msg
	    } on return {msg opt} {
		dict incr opt -level 2
		return -options $opt $msg
	    } on break {} {
		return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
		    "property getter for $prop did a break"
	    } on continue {} {
		return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
		    "property getter for $prop did a continue"
	    }
	    return $value
	}

	# ------------------------------------------------------------------
	#
	# oo::configuresupport::WriteMany --
	#
	#	The implementation of [$o configure -prop val ?-prop val...?].
	#
	# ------------------------------------------------------------------

	proc WriteMany {object my setterMap} {
	    set props [info object properties $object -all -writable]
	    foreach {prop value} $setterMap {
		try {
		    set prop [prefix match -message "property" $props $prop]
		} on error {msg} {
		    catch {
			set rps [info object properties $object -all -readable]
			set rprop [prefix match $rps $prop]
			set msg "property \"$rprop\" is read only"
		    }
		    return -code error -level 2 -errorcode [list \
			    TCL LOOKUP INDEX property $prop] $msg
		}
		try {
		    $my <WriteProp$prop> $value
		} on error {msg opt} {
		    dict set opt -level 2
		    return -options $opt $msg
		} on return {msg opt} {
		    dict incr opt -level 2
		    return -options $opt $msg
		} on break {} {
		    return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
			"property setter for $prop did a break"
		} on continue {} {
		    return -code error -level 2 -errorcode {TCLOO SHENANIGANS} \
			"property setter for $prop did a continue"
		}
	    }
	    return
	}

	# ------------------------------------------------------------------
	#
	# oo::configuresupport::configurable --
	#
	#	The class that contains the implementation of the actual
	#	'configure' method (mixed into actually configurable classes).
	#	Great care needs to be taken in these methods as they are
	#	potentially used in classes where the current namespace is set
	#	up very strangely.
	#
	# ------------------------------------------------------------------

	::oo::class create configurable {
	    private variable my
	    #
	    # configure --
	    #	Method for providing client access to the property mechanism.
	    #	Has a user-facing API similar to that of [chan configure].
	    #
	    method configure -export args {
		::if {![::info exists my]} {
		    ::set my [::namespace which my]
		}
		::if {[::llength $args] == 0} {
		    # Read all properties
		    ::oo::configuresupport::ReadAll [self] $my
		} elseif {[::llength $args] == 1} {
		    # Read a single property
		    ::oo::configuresupport::ReadOne [self] $my \
			[::lindex $args 0]
		} elseif {[::llength $args] % 2 == 0} {
		    # Set properties, one or several
		    ::oo::configuresupport::WriteMany [self] $my $args
		} else {
		    # Invalid call
		    ::return -code error -errorcode {TCL WRONGARGS} \
			[::format {wrong # args: should be "%s"} \
			    "[self] configure ?-option value ...?"]
		}
	    }

	    definitionnamespace -instance configurableobject
	    definitionnamespace -class configurableclass
	}
    }

    # ----------------------------------------------------------------------
    #
    # oo::configurable --
    #
    #	A metaclass that is used to make classes that can be configured in
    #	their creation phase (and later too). All the metaclass itself does is
    #	arrange for the class created to have a 'configure' method and for
    #	oo::define and oo::objdefine (on the class and its instances) to have
    #	a property definition for setting things up for 'configure'.
    #
    # ----------------------------------------------------------------------

    class create configurable {
	superclass class

	constructor {{definitionScript ""}} {
	    next {mixin ::oo::configuresupport::configurable}
	    next $definitionScript
	}

	definitionnamespace -class configuresupport::configurableclass
    }
}

# Local Variables:
# mode: tcl
# c-basic-offset: 4
# fill-column: 78
# End: