/*
* tclOOProp.c --
*
* This file contains implementations of the configurable property
* mecnanisms.
*
* Copyright © 2023-2024 Donal K. Fellows
*
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*/
#include "tclOOInt.h"
/* Short-term cache for GetPropertyName(). */
typedef struct GPNCache {
Tcl_Obj *listPtr; /* Holds references to names. */
char *names[TCLFLEXARRAY]; /* NULL-terminated table of names. */
} GPNCache;
enum GPNFlags {
GPN_WRITABLE = 1, /* Are we looking for a writable property? */
GPN_FALLING_BACK = 2 /* Are we doing a recursive call to determine
* if the property is of the other type? */
};
/*
* Shared bits for [property] declarations.
*/
enum PropOpt {
PROP_ALL, PROP_READABLE, PROP_WRITABLE
};
static const char *const propOptNames[] = {
"-all", "-readable", "-writable",
NULL
};
/*
* Forward declarations.
*/
static int Configurable_Getter(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static int Configurable_Setter(void *clientData,
Tcl_Interp *interp, Tcl_ObjectContext context,
int objc, Tcl_Obj *const *objv);
static void DetailsDeleter(void *clientData);
static int DetailsCloner(Tcl_Interp *, void *oldClientData,
void **newClientData);
static void ImplementObjectProperty(Tcl_Object targetObject,
Tcl_Obj *propNamePtr, int installGetter,
int installSetter);
static void ImplementClassProperty(Tcl_Class targetObject,
Tcl_Obj *propNamePtr, int installGetter,
int installSetter);
/*
* Method descriptors
*/
static const Tcl_MethodType GetterType = {
TCL_OO_METHOD_VERSION_1,
"PropertyGetter",
Configurable_Getter,
DetailsDeleter,
DetailsCloner
};
static const Tcl_MethodType SetterType = {
TCL_OO_METHOD_VERSION_1,
"PropertySetter",
Configurable_Setter,
DetailsDeleter,
DetailsCloner
};
/*
* ----------------------------------------------------------------------
*
* TclOO_Configurable_Configure --
*
* Implementation of the oo::configurable->configure method.
*
* ----------------------------------------------------------------------
*/
/*
* Ugly thunks to read and write a property by calling the right method in
* the right way. Note that we MUST be correct in holding references to Tcl_Obj
* values, as this is potentially a call into user code.
*/
static inline int
ReadProperty(
Tcl_Interp *interp,
Object *oPtr,
const char *propName)
{
Tcl_Obj *args[] = {
oPtr->fPtr->myName,
Tcl_ObjPrintf("<ReadProp%s>", propName)
};
int code;
Tcl_IncrRefCount(args[0]);
Tcl_IncrRefCount(args[1]);
code = TclOOPrivateObjectCmd(oPtr, interp, 2, args);
Tcl_DecrRefCount(args[0]);
Tcl_DecrRefCount(args[1]);
switch (code) {
case TCL_BREAK:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"property getter for %s did a break", propName));
return TCL_ERROR;
case TCL_CONTINUE:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"property getter for %s did a continue", propName));
return TCL_ERROR;
default:
return code;
}
}
static inline int
WriteProperty(
Tcl_Interp *interp,
Object *oPtr,
const char *propName,
Tcl_Obj *valueObj)
{
Tcl_Obj *args[] = {
oPtr->fPtr->myName,
Tcl_ObjPrintf("<WriteProp%s>", propName),
valueObj
};
int code;
Tcl_IncrRefCount(args[0]);
Tcl_IncrRefCount(args[1]);
Tcl_IncrRefCount(args[2]);
code = TclOOPrivateObjectCmd(oPtr, interp, 3, args);
Tcl_DecrRefCount(args[0]);
Tcl_DecrRefCount(args[1]);
Tcl_DecrRefCount(args[2]);
switch (code) {
case TCL_BREAK:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"property setter for %s did a break", propName));
return TCL_ERROR;
case TCL_CONTINUE:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"property setter for %s did a continue", propName));
return TCL_ERROR;
default:
return code;
}
}
/* Look up a property full name. */
static Tcl_Obj *
GetPropertyName(
Tcl_Interp *interp, /* Context and error reporting. */
Object *oPtr, /* Object to get property name from. */
int flags, /* Are we looking for a writable property?
* Can we do a fallback message?
* See GPNFlags for possible values */
Tcl_Obj *namePtr, /* The name supplied by the user. */
GPNCache **cachePtr) /* Where to cache the table, if the caller
* wants that. The contents are to be freed
* with Tcl_Free if the cache is used. */
{
Tcl_Size objc, index, i;
Tcl_Obj *listPtr = TclOOGetAllObjectProperties(
oPtr, flags & GPN_WRITABLE);
Tcl_Obj **objv;
GPNCache *tablePtr;
(void) Tcl_ListObjGetElements(NULL, listPtr, &objc, &objv);
if (cachePtr && *cachePtr) {
tablePtr = *cachePtr;
} else {
tablePtr = (GPNCache *) TclStackAlloc(interp,
offsetof(GPNCache, names) + sizeof(char *) * (objc + 1));
for (i = 0; i < objc; i++) {
tablePtr->names[i] = TclGetString(objv[i]);
}
tablePtr->names[objc] = NULL;
if (cachePtr) {
/*
* Have a cache, but nothing in it so far.
*
* We cache the list here so it doesn't vanish from under our
* feet if a property implementation does something crazy like
* changing the set of properties. The type of copy this does
* means that the copy holds the references to the names in the
* table.
*/
tablePtr->listPtr = TclDuplicatePureObj(interp ,listPtr ,tclListTypePtr);
Tcl_IncrRefCount(tablePtr->listPtr);
*cachePtr = tablePtr;
} else {
tablePtr->listPtr = NULL;
}
}
int result = Tcl_GetIndexFromObjStruct(interp, namePtr, tablePtr->names,
sizeof(char *), "property", TCL_INDEX_TEMP_TABLE, &index);
if (result == TCL_ERROR && !(flags & GPN_FALLING_BACK)) {
/*
* If property can be accessed the other way, use a special message.
* We use a recursive call to look this up.
*/
Tcl_InterpState foo = Tcl_SaveInterpState(interp, result);
Tcl_Obj *otherName = GetPropertyName(interp, oPtr,
flags ^ (GPN_WRITABLE | GPN_FALLING_BACK), namePtr, NULL);
result = Tcl_RestoreInterpState(interp, foo);
if (otherName != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"property \"%s\" is %s only",
TclGetString(otherName),
(flags & GPN_WRITABLE) ? "read" : "write"));
}
}
if (!cachePtr) {
TclStackFree(interp, tablePtr);
}
if (result != TCL_OK) {
return NULL;
}
return objv[index];
}
/* Release the cache made by GetPropertyName(). */
static inline void
ReleasePropertyNameCache(
Tcl_Interp *interp,
GPNCache **cachePtr)
{
if (*cachePtr) {
GPNCache *tablePtr = *cachePtr;
if (tablePtr->listPtr) {
Tcl_DecrRefCount(tablePtr->listPtr);
}
TclStackFree(interp, tablePtr);
*cachePtr = NULL;
}
}
int
TclOO_Configurable_Configure(
TCL_UNUSED(void *),
Tcl_Interp *interp, /* Interpreter used for the result, error
* reporting, etc. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Object *oPtr = (Object *) Tcl_ObjectContextObject(context);
Tcl_Size skip = Tcl_ObjectContextSkippedArgs(context);
Tcl_Obj *namePtr;
Tcl_Size i, namec;
int code = TCL_OK;
objc -= skip;
if ((objc & 1) && (objc != 1)) {
/*
* Bad (odd > 1) number of arguments.
*/
Tcl_WrongNumArgs(interp, skip, objv, "?-option value ...?");
return TCL_ERROR;
}
objv += skip;
if (objc == 0) {
/*
* Read all properties.
*/
Tcl_Obj *listPtr = TclOOGetAllObjectProperties(oPtr, 0);
Tcl_Obj *resultPtr = Tcl_NewObj(), **namev;
Tcl_IncrRefCount(listPtr);
ListObjGetElements(listPtr, namec, namev);
for (i = 0; i < namec; ) {
code = ReadProperty(interp, oPtr, TclGetString(namev[i]));
if (code != TCL_OK) {
Tcl_DecrRefCount(resultPtr);
break;
}
Tcl_DictObjPut(NULL, resultPtr, namev[i],
Tcl_GetObjResult(interp));
if (++i >= namec) {
Tcl_SetObjResult(interp, resultPtr);
break;
}
Tcl_SetObjResult(interp, Tcl_NewObj());
}
Tcl_DecrRefCount(listPtr);
return code;
} else if (objc == 1) {
/*
* Read a single named property.
*/
namePtr = GetPropertyName(interp, oPtr, 0, objv[0], NULL);
if (namePtr == NULL) {
return TCL_ERROR;
}
return ReadProperty(interp, oPtr, TclGetString(namePtr));
} else if (objc == 2) {
/*
* Special case for writing to one property. Saves fiddling with the
* cache in this common case.
*/
namePtr = GetPropertyName(interp, oPtr, GPN_WRITABLE, objv[0], NULL);
if (namePtr == NULL) {
return TCL_ERROR;
}
code = WriteProperty(interp, oPtr, TclGetString(namePtr), objv[1]);
if (code == TCL_OK) {
Tcl_ResetResult(interp);
}
return code;
} else {
/*
* Write properties. Slightly tricky because we want to cache the
* table of property names.
*/
GPNCache *cache = NULL;
code = TCL_OK;
for (i = 0; i < objc; i += 2) {
namePtr = GetPropertyName(interp, oPtr, GPN_WRITABLE, objv[i],
&cache);
if (namePtr == NULL) {
code = TCL_ERROR;
break;
}
code = WriteProperty(interp, oPtr, TclGetString(namePtr),
objv[i + 1]);
if (code != TCL_OK) {
break;
}
}
if (code == TCL_OK) {
Tcl_ResetResult(interp);
}
ReleasePropertyNameCache(interp, &cache);
return code;
}
}
/*
* ----------------------------------------------------------------------
*
* Configurable_Getter, Configurable_Setter --
*
* Standard property implementation. The clientData is a simple Tcl_Obj*
* that contains the name of the property.
*
* ----------------------------------------------------------------------
*/
static int
Configurable_Getter(
void *clientData, /* Which property to read. Actually a Tcl_Obj*
* reference that is the name of the variable
* in the cpntext object. */
Tcl_Interp *interp, /* Interpreter used for the result, error
* reporting, etc. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Tcl_Obj *propNamePtr = (Tcl_Obj *) clientData;
Tcl_Var varPtr, aryVar;
Tcl_Obj *valuePtr;
if ((int) Tcl_ObjectContextSkippedArgs(context) != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context),
objv, NULL);
return TCL_ERROR;
}
varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context),
propNamePtr, &aryVar);
if (varPtr == NULL) {
return TCL_ERROR;
}
valuePtr = TclPtrGetVar(interp, varPtr, aryVar, propNamePtr, NULL,
TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG);
if (valuePtr == NULL) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, valuePtr);
return TCL_OK;
}
static int
Configurable_Setter(
void *clientData, /* Which property to write. Actually a Tcl_Obj*
* reference that is the name of the variable
* in the cpntext object. */
Tcl_Interp *interp, /* Interpreter used for the result, error
* reporting, etc. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Tcl_Obj *propNamePtr = (Tcl_Obj *) clientData;
Tcl_Var varPtr, aryVar;
if ((int) Tcl_ObjectContextSkippedArgs(context) + 1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context),
objv, "value");
return TCL_ERROR;
}
varPtr = TclOOLookupObjectVar(interp, Tcl_ObjectContextObject(context),
propNamePtr, &aryVar);
if (varPtr == NULL) {
return TCL_ERROR;
}
if (TclPtrSetVar(interp, varPtr, aryVar, propNamePtr, NULL,
objv[objc - 1], TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
return TCL_OK;
}
// Simple support functions
static void
DetailsDeleter(
void *clientData)
{
// Just drop the reference count
Tcl_Obj *propNamePtr = (Tcl_Obj *) clientData;
Tcl_DecrRefCount(propNamePtr);
}
static int
DetailsCloner(
TCL_UNUSED(Tcl_Interp *),
void *oldClientData,
void **newClientData)
{
// Just add another reference to this name; easy!
Tcl_Obj *propNamePtr = (Tcl_Obj *) oldClientData;
Tcl_IncrRefCount(propNamePtr);
*newClientData = propNamePtr;
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* ImplementObjectProperty, ImplementClassProperty --
*
* Installs a basic property implementation for a property, either on
* an instance or on a class. It's up to the code that calls these
* to ensure that the property name is syntactically valid.
*
* ----------------------------------------------------------------------
*/
void
ImplementObjectProperty(
Tcl_Object targetObject, /* What to install into. */
Tcl_Obj *propNamePtr, /* Property name. */
int installGetter, /* Whether to install a standard getter. */
int installSetter) /* Whether to install a standard setter. */
{
const char *propName = TclGetString(propNamePtr);
while (propName[0] == '-') {
propName++;
}
if (installGetter) {
Tcl_Obj *methodName = Tcl_ObjPrintf("<ReadProp-%s>", propName);
Tcl_IncrRefCount(propNamePtr); // Paired with DetailsDeleter
TclNewInstanceMethod(
NULL, targetObject, methodName, 0, &GetterType, propNamePtr);
Tcl_BounceRefCount(methodName);
}
if (installSetter) {
Tcl_Obj *methodName = Tcl_ObjPrintf("<WriteProp-%s>", propName);
Tcl_IncrRefCount(propNamePtr); // Paired with DetailsDeleter
TclNewInstanceMethod(
NULL, targetObject, methodName, 0, &SetterType, propNamePtr);
Tcl_BounceRefCount(methodName);
}
}
void
ImplementClassProperty(
Tcl_Class targetClass, /* What to install into. */
Tcl_Obj *propNamePtr, /* Property name. */
int installGetter, /* Whether to install a standard getter. */
int installSetter) /* Whether to install a standard setter. */
{
const char *propName = TclGetString(propNamePtr);
while (propName[0] == '-') {
propName++;
}
if (installGetter) {
Tcl_Obj *methodName = Tcl_ObjPrintf("<ReadProp-%s>", propName);
Tcl_IncrRefCount(propNamePtr); // Paired with DetailsDeleter
TclNewMethod(targetClass, methodName, 0, &GetterType, propNamePtr);
Tcl_BounceRefCount(methodName);
}
if (installSetter) {
Tcl_Obj *methodName = Tcl_ObjPrintf("<WriteProp-%s>", propName);
Tcl_IncrRefCount(propNamePtr); // Paired with DetailsDeleter
TclNewMethod(targetClass, methodName, 0, &SetterType, propNamePtr);
Tcl_BounceRefCount(methodName);
}
}
/*
* ----------------------------------------------------------------------
*
* FindClassProps --
*
* Discover the properties known to a class and its superclasses.
* The property names become the keys in the accumulator hash table
* (which is used as a set).
*
* ----------------------------------------------------------------------
*/
static void
FindClassProps(
Class *clsPtr, /* The object to inspect. Must exist. */
int writable, /* Whether we're after the readable or writable
* property set. */
Tcl_HashTable *accumulator) /* Where to gather the names. */
{
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);
}
}
/*
* ----------------------------------------------------------------------
*
* FindObjectProps --
*
* Discover the properties known to an object and all its classes.
* The property names become the keys in the accumulator hash table
* (which is used as a set).
*
* ----------------------------------------------------------------------
*/
static void
FindObjectProps(
Object *oPtr, /* The object to inspect. Must exist. */
int writable, /* Whether we're after the readable or writable
* property set. */
Tcl_HashTable *accumulator) /* Where to gather the names. */
{
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);
}
/*
* ----------------------------------------------------------------------
*
* GetAllClassProperties --
*
* Get the list of all properties known to a class, including to its
* superclasses. Manages a cache so this operation is usually cheap.
* The order of properties in the resulting list is undefined.
*
* ----------------------------------------------------------------------
*/
static Tcl_Obj *
GetAllClassProperties(
Class *clsPtr, /* The class to inspect. Must exist. */
int writable, /* Whether to get writable properties. If
* false, readable properties will be returned
* instead. */
int *allocated) /* Address of variable to set to true if a
* Tcl_Obj was allocated and may be safely
* modified by the caller. */
{
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);
TclNewObj(result);
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;
}
/*
* ----------------------------------------------------------------------
*
* 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 TclStringCmp(first, second, 0, 0, TCL_INDEX_NONE);
}
static inline void
SortPropList(
Tcl_Obj *list)
{
Tcl_Size ec;
Tcl_Obj **ev;
if (Tcl_IsShared(list)) {
Tcl_Panic("shared property list cannot be sorted");
}
Tcl_ListObjGetElements(NULL, list, &ec, &ev);
TclInvalidateStringRep(list);
qsort(ev, ec, sizeof(Tcl_Obj *), PropNameCompare);
}
/*
* ----------------------------------------------------------------------
*
* TclOOGetAllObjectProperties --
*
* Get the sorted list of all properties known to an object, including to
* its classes. Manages a cache so this operation is usually cheap.
*
* ----------------------------------------------------------------------
*/
Tcl_Obj *
TclOOGetAllObjectProperties(
Object *oPtr, /* The object to inspect. Must exist. */
int writable) /* Whether to get writable properties. If
* false, readable properties will be returned
* instead. */
{
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) {
return oPtr->properties.allWritableCache;
}
} else {
if (oPtr->properties.allReadableCache) {
return oPtr->properties.allReadableCache;
}
}
}
/*
* Gather the information. Unsorted! (Caller will sort.)
*/
Tcl_InitObjHashTable(&hashTable);
FindObjectProps(oPtr, writable, &hashTable);
TclNewObj(result);
FOREACH_HASH(propName, dummy, &hashTable) {
Tcl_ListObjAppendElement(NULL, result, propName);
}
Tcl_DeleteHashTable(&hashTable);
SortPropList(result);
/*
* 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;
}
/*
* ----------------------------------------------------------------------
*
* SetPropertyList --
*
* Helper for writing a property list (which is actually a set).
*
* ----------------------------------------------------------------------
*/
static inline void
SetPropertyList(
PropertyList *propList, /* The property list to write. Replaces the
* property list's contents. */
Tcl_Size objc, /* Number of property names. */
Tcl_Obj *const objv[]) /* Property names. */
{
Tcl_Size i, n;
Tcl_Obj *propObj;
int created;
Tcl_HashTable uniqueTable;
for (i=0 ; i<objc ; i++) {
Tcl_IncrRefCount(objv[i]);
}
FOREACH(propObj, *propList) {
Tcl_DecrRefCount(propObj);
}
if (i != objc) {
if (objc == 0) {
Tcl_Free(propList->list);
} else if (i) {
propList->list = (Tcl_Obj **)
Tcl_Realloc(propList->list, sizeof(Tcl_Obj *) * objc);
} else {
propList->list = (Tcl_Obj **)
Tcl_Alloc(sizeof(Tcl_Obj *) * objc);
}
}
propList->num = 0;
if (objc > 0) {
Tcl_InitObjHashTable(&uniqueTable);
for (i=n=0 ; i<objc ; i++) {
Tcl_CreateHashEntry(&uniqueTable, objv[i], &created);
if (created) {
propList->list[n++] = objv[i];
} else {
Tcl_DecrRefCount(objv[i]);
}
}
propList->num = n;
/*
* Shouldn't be necessary, but maintain num/list invariant.
*/
if (n != objc) {
propList->list = (Tcl_Obj **)
Tcl_Realloc(propList->list, sizeof(Tcl_Obj *) * n);
}
Tcl_DeleteHashTable(&uniqueTable);
}
}
/*
* ----------------------------------------------------------------------
*
* TclOOInstallReadableProperties --
*
* Helper for writing the readable property list (which is actually a set)
* that includes flushing the name cache.
*
* ----------------------------------------------------------------------
*/
void
TclOOInstallReadableProperties(
PropertyStorage *props, /* Which property list to install into. */
Tcl_Size objc, /* Number of property names. */
Tcl_Obj *const objv[]) /* Property names. */
{
if (props->allReadableCache) {
Tcl_DecrRefCount(props->allReadableCache);
props->allReadableCache = NULL;
}
SetPropertyList(&props->readable, objc, objv);
}
/*
* ----------------------------------------------------------------------
*
* TclOOInstallWritableProperties --
*
* Helper for writing the writable property list (which is actually a set)
* that includes flushing the name cache.
*
* ----------------------------------------------------------------------
*/
void
TclOOInstallWritableProperties(
PropertyStorage *props, /* Which property list to install into. */
Tcl_Size objc, /* Number of property names. */
Tcl_Obj *const objv[]) /* Property names. */
{
if (props->allWritableCache) {
Tcl_DecrRefCount(props->allWritableCache);
props->allWritableCache = NULL;
}
SetPropertyList(&props->writable, objc, objv);
}
/*
* ----------------------------------------------------------------------
*
* TclOOGetPropertyList --
*
* Helper for reading a property list.
*
* ----------------------------------------------------------------------
*/
Tcl_Obj *
TclOOGetPropertyList(
PropertyList *propList) /* The property list to read. */
{
Tcl_Obj *resultObj, *propNameObj;
Tcl_Size i;
TclNewObj(resultObj);
FOREACH(propNameObj, *propList) {
Tcl_ListObjAppendElement(NULL, resultObj, propNameObj);
}
return resultObj;
}
/*
* ----------------------------------------------------------------------
*
* TclOOInstallStdPropertyImpls --
*
* Validates a (dashless) property name, and installs implementation
* methods if asked to do so (readable and writable flags).
*
* ----------------------------------------------------------------------
*/
int
TclOOInstallStdPropertyImpls(
void *useInstance,
Tcl_Interp *interp,
Tcl_Obj *propName,
int readable,
int writable)
{
const char *name, *reason;
Tcl_Size len;
char flag = TCL_DONT_QUOTE_HASH;
/*
* Validate the property name. Note that just calling TclScanElement() is
* cheaper than actually formatting a list and comparing the string
* version of that with the original, as TclScanElement() is one of the
* core parts of doing that; this skips a whole load of irrelevant memory
* allocations!
*/
name = Tcl_GetStringFromObj(propName, &len);
if (Tcl_StringMatch(name, "-*")) {
reason = "must not begin with -";
goto badProp;
}
if (TclScanElement(name, len, &flag) != len) {
reason = "must be a simple word";
goto badProp;
}
if (Tcl_StringMatch(name, "*::*")) {
reason = "must not contain namespace separators";
goto badProp;
}
if (Tcl_StringMatch(name, "*[()]*")) {
reason = "must not contain parentheses";
goto badProp;
}
/*
* Install the implementations... if asked to do so.
*/
if (useInstance) {
Tcl_Object object = TclOOGetDefineCmdContext(interp);
if (!object) {
return TCL_ERROR;
}
ImplementObjectProperty(object, propName, readable, writable);
} else {
Tcl_Class cls = (Tcl_Class) TclOOGetClassDefineCmdContext(interp);
if (!cls) {
return TCL_ERROR;
}
ImplementClassProperty(cls, propName, readable, writable);
}
return TCL_OK;
badProp:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad property name \"%s\": %s", name, reason));
Tcl_SetErrorCode(interp, "TCL", "OO", "PROPERTY_FORMAT", NULL);
return TCL_ERROR;
}
/*
* ----------------------------------------------------------------------
*
* TclOODefinePropertyCmd --
*
* Implementation of the "property" definition for classes and instances
* governed by the [oo::configurable] metaclass.
*
* ----------------------------------------------------------------------
*/
int
TclOODefinePropertyCmd(
void *useInstance, /* NULL for class, non-NULL for object. */
Tcl_Interp *interp, /* For error reporting and lookup. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* Arguments. */
{
int i;
const char *const options[] = {
"-get", "-kind", "-set", NULL
};
enum Options {
OPT_GET, OPT_KIND, OPT_SET
};
const char *const kinds[] = {
"readable", "readwrite", "writable", NULL
};
enum Kinds {
KIND_RO, KIND_RW, KIND_WO
};
Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
if (oPtr == NULL) {
return TCL_ERROR;
}
if (!useInstance && !oPtr->classPtr) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"attempt to misuse API", TCL_AUTO_LENGTH));
Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", (char *)NULL);
return TCL_ERROR;
}
for (i = 1; i < objc; i++) {
Tcl_Obj *propObj = objv[i], *nextObj, *argObj, *hyphenated;
Tcl_Obj *getterScript = NULL, *setterScript = NULL;
/*
* Parse the extra options for the property.
*/
int kind = KIND_RW;
while (i + 1 < objc) {
int option;
nextObj = objv[i + 1];
if (TclGetString(nextObj)[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, nextObj, options, "option", 0,
&option) != TCL_OK) {
return TCL_ERROR;
}
if (i + 2 >= objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"missing %s to go with %s option",
(option == OPT_KIND ? "kind value" : "body"),
options[option]));
Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", NULL);
return TCL_ERROR;
}
argObj = objv[i + 2];
i += 2;
switch (option) {
case OPT_GET:
getterScript = argObj;
break;
case OPT_SET:
setterScript = argObj;
break;
case OPT_KIND:
if (Tcl_GetIndexFromObj(interp, argObj, kinds, "kind", 0,
&kind) != TCL_OK) {
return TCL_ERROR;
}
break;
}
}
/*
* Install the property. Note that TclOOInstallStdPropertyImpls
* validates the property name as well.
*/
if (TclOOInstallStdPropertyImpls(useInstance, interp, propObj,
kind != KIND_WO && getterScript == NULL,
kind != KIND_RO && setterScript == NULL) != TCL_OK) {
return TCL_ERROR;
}
hyphenated = Tcl_ObjPrintf("-%s", TclGetString(propObj));
if (useInstance) {
TclOORegisterInstanceProperty(oPtr, hyphenated,
kind != KIND_WO, kind != KIND_RO);
} else {
TclOORegisterProperty(oPtr->classPtr, hyphenated,
kind != KIND_WO, kind != KIND_RO);
}
Tcl_BounceRefCount(hyphenated);
/*
* Create property implementation methods by using the right
* back-end API, but only if the user has given us the bodies of the
* methods we'll make.
*/
if (getterScript != NULL) {
Tcl_Obj *getterName = Tcl_ObjPrintf("<ReadProp-%s>",
TclGetString(propObj));
Tcl_Obj *argsPtr = Tcl_NewObj();
Method *mPtr;
Tcl_IncrRefCount(getterScript);
if (useInstance) {
mPtr = TclOONewProcInstanceMethod(interp, oPtr, 0,
getterName, argsPtr, getterScript, NULL);
} else {
mPtr = TclOONewProcMethod(interp, oPtr->classPtr, 0,
getterName, argsPtr, getterScript, NULL);
}
Tcl_BounceRefCount(getterName);
Tcl_BounceRefCount(argsPtr);
Tcl_DecrRefCount(getterScript);
if (mPtr == NULL) {
return TCL_ERROR;
}
}
if (setterScript != NULL) {
Tcl_Obj *setterName = Tcl_ObjPrintf("<WriteProp-%s>",
TclGetString(propObj));
Tcl_Obj *argsPtr;
Method *mPtr;
TclNewLiteralStringObj(argsPtr, "value");
Tcl_IncrRefCount(setterScript);
if (useInstance) {
mPtr = TclOONewProcInstanceMethod(interp, oPtr, 0,
setterName, argsPtr, setterScript, NULL);
} else {
mPtr = TclOONewProcMethod(interp, oPtr->classPtr, 0,
setterName, argsPtr, setterScript, NULL);
}
Tcl_BounceRefCount(setterName);
Tcl_BounceRefCount(argsPtr);
Tcl_DecrRefCount(setterScript);
if (mPtr == NULL) {
return TCL_ERROR;
}
}
}
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TclOOInfoClassPropCmd, TclOOInfoObjectPropCmd --
*
* Implements [info class properties $clsName ?$option...?] and
* [info object properties $objName ?$option...?]
*
* ----------------------------------------------------------------------
*/
int
TclOOInfoClassPropCmd(
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;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "className ?options...?");
return TCL_ERROR;
}
clsPtr = TclOOGetClassFromObj(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 = GetAllClassProperties(clsPtr, writable, &allocated);
if (allocated) {
SortPropList(result);
}
} else {
if (writable) {
result = TclOOGetPropertyList(&clsPtr->properties.writable);
} else {
result = TclOOGetPropertyList(&clsPtr->properties.readable);
}
SortPropList(result);
}
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
int
TclOOInfoObjectPropCmd(
TCL_UNUSED(void *),
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Object *oPtr;
int i, idx, all = 0, writable = 0;
Tcl_Obj *result;
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);
} else {
if (writable) {
result = TclOOGetPropertyList(&oPtr->properties.writable);
} else {
result = TclOOGetPropertyList(&oPtr->properties.readable);
}
SortPropList(result);
}
Tcl_SetObjResult(interp, result);
return TCL_OK;
}
/*
* ----------------------------------------------------------------------
*
* TclOOReleasePropertyStorage --
*
* Delete the memory associated with a class or object's properties.
*
* ----------------------------------------------------------------------
*/
static inline void
ReleasePropertyList(
PropertyList *propList)
{
Tcl_Obj *propertyObj;
Tcl_Size i;
FOREACH(propertyObj, *propList) {
Tcl_DecrRefCount(propertyObj);
}
Tcl_Free(propList->list);
propList->list = NULL;
propList->num = 0;
}
void
TclOOReleasePropertyStorage(
PropertyStorage *propsPtr)
{
if (propsPtr->allReadableCache) {
Tcl_DecrRefCount(propsPtr->allReadableCache);
}
if (propsPtr->allWritableCache) {
Tcl_DecrRefCount(propsPtr->allWritableCache);
}
if (propsPtr->readable.num) {
ReleasePropertyList(&propsPtr->readable);
}
if (propsPtr->writable.num) {
ReleasePropertyList(&propsPtr->writable);
}
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/