/*
*----------------------------------------------------------------------
*
* NsfMethodObjSet --
*
* Convert the provided Tcl_Obj into the type of NsfMethodContext.
*
*----------------------------------------------------------------------
*/
int
NsfMethodObjSet(
Tcl_Interp *UNUSED(interp), /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr, /* The object to convert. */
const Tcl_ObjType *objectType,
void *context, /* context (to avoid over-eager sharing) */
unsigned int methodEpoch, /* methodEpoch */
Tcl_Command cmd, /* the Tcl command behind the method */
NsfClass *cl, /* the object/class where the method was defined */
unsigned int flags /* flags */
) {
NsfMethodContext *mcPtr;
#if defined(METHOD_OBJECT_TRACE)
fprintf(stderr, "... NsfMethodObjSet %p %s context %p methodEpoch %d "
"cmd %p cl %p %s old obj type <%s> flags %.6x\n",
objPtr, ObjStr(objPtr), context, methodEpoch, cmd, cl,
(cl != NULL) ? ClassName(cl) : "obj",
(objPtr->typePtr != NULL) ? objPtr->typePtr->name : "none", flags);
#endif
/*
* Free or reuse the old internal representation and store own
* structure as internal representation.
*/
if (objPtr->typePtr != objectType) {
#if defined(METHOD_OBJECT_TRACE)
fprintf(stderr, "... NsfMethodObjSet frees old int rep %s\n", (objPtr->typePtr != NULL) ? objPtr->typePtr->name : "none");
#endif
TclFreeIntRep(objPtr);
mcPtr = NEW(NsfMethodContext);
/*fprintf(stderr, "NsfMethodObjSet allocated NsfMethodContext %p for %s\n", mcPtr, ObjStr(objPtr));*/
objPtr->internalRep.twoPtrValue.ptr1 = (void *)mcPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = objectType;
#if defined(METHOD_OBJECT_TRACE)
fprintf(stderr, "alloc %p methodContext %p methodEpoch %d type <%s> %s refCount %d\n",
objPtr, mcPtr, methodEpoch, objectType->name, ObjStr(objPtr), objPtr->refCount);
#endif
} else {
mcPtr = (NsfMethodContext *)objPtr->internalRep.twoPtrValue.ptr1;
#if defined(METHOD_OBJECT_TRACE)
fprintf(stderr, "... NsfMethodObjSet %p reuses internal rep, serial (%d/%d) refCount %d\n",
objPtr, mcPtr->methodEpoch, methodEpoch, objPtr->refCount);
#endif
}
assert(mcPtr != NULL);
/*
* add values to the structure
*/
mcPtr->context = context;
mcPtr->methodEpoch = methodEpoch;
mcPtr->cmd = cmd;
mcPtr->cl = cl;
mcPtr->flags = flags;
return TCL_OK;
}
int
GetIndexFromObjList(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object containing the string to lookup. */
Tcl_Obj *tableObjPtr, /* List of strings to compare against the
* value of objPtr. */
const char *msg, /* Identifying word to use in error
* messages. */
int flags, /* 0 or TCL_EXACT */
int *indexPtr) /* Place to store resulting integer index. */
{
int objc, result, t;
Tcl_Obj **objv;
const char **tablePtr;
/*
* Use Tcl_GetIndexFromObjStruct to do the work to avoid duplicating most
* of the code there. This is a bit ineffiecient but simpler.
*/
result = Tcl_ListObjGetElements(interp, tableObjPtr, &objc, &objv);
if (result != TCL_OK) {
return result;
}
/*
* Build a string table from the list.
*/
tablePtr = ckalloc((objc + 1) * sizeof(char *));
for (t = 0; t < objc; t++) {
if (objv[t] == objPtr) {
/*
* An exact match is always chosen, so we can stop here.
*/
ckfree(tablePtr);
*indexPtr = t;
return TCL_OK;
}
tablePtr[t] = Tcl_GetString(objv[t]);
}
tablePtr[objc] = NULL;
result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr,
sizeof(char *), msg, flags, indexPtr);
/*
* The internal rep must be cleared since tablePtr will go away.
*/
TclFreeIntRep(objPtr);
ckfree(tablePtr);
return result;
}
/*
* setFromAnyProc
*/
static int
FilterregSetFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr /* The object to convert. */
) {
Tcl_Obj *guardObj = NULL, *filterObj;
Filterreg *filterregPtr;
int oc; Tcl_Obj **ov;
if (Tcl_ListObjGetElements(interp, objPtr, &oc, &ov) == TCL_OK) {
if (oc == 1) {
filterObj = ov[0];
/* } else if (oc == 2) {
filterObj = ov[0];
guardObj = ov[1];*/
} else if (oc == 3 && !strcmp(ObjStr(ov[1]), NsfGlobalStrings[NSF_GUARD_OPTION])) {
filterObj = ov[0];
guardObj = ov[2];
} else {
return TCL_ERROR;
}
} else {
return TCL_ERROR;
}
/*
* Conversion was ok.
* Allocate structure ...
*/
filterregPtr = NEW(Filterreg);
filterregPtr->filterObj = filterObj;
filterregPtr->guardObj = guardObj;
/*
* ... and increment refCounts
*/
INCR_REF_COUNT2("filterregPtr->filterObj", filterObj);
if (guardObj != NULL) {INCR_REF_COUNT2("filterregPtr->guardObj", guardObj);}
/*fprintf(stderr, "FilterregSetFromAny alloc filterreg %p class %p guard %p\n",
filterregPtr, filterregPtr->filterObj, filterregPtr->guardObj);*/
/*
* Free the old internal representation and store own structure as internal
* representation.
*/
TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = (void *)filterregPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &NsfFilterregObjType;
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* NsfFlagObjSet --
*
* Convert the provided Tcl_Obj into the type of an NSF flag.
*
*----------------------------------------------------------------------
*/
int
NsfFlagObjSet(
Tcl_Interp *UNUSED(interp), /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr, /* The object to convert. */
Nsf_Param const *baseParamPtr, /* the full parameter block */
int serial, /* interface serial */
Nsf_Param const *paramPtr, /* a single parameter */
Tcl_Obj *payload, /* payload */
unsigned int flags /* detail infos */
) {
NsfFlag *flagPtr;
/*fprintf(stderr, "NsfFlagObjSet %p %s signature %p (%d) param %p payload %p flags %.4x\n",
objPtr, ObjStr(objPtr), baseParamPtr, serial, paramPtr, payload, flags);*/
/*
* Free or reuse the old internal representation and store own
* structure as internal representation.
*/
if (objPtr->typePtr != &NsfFlagObjType) {
TclFreeIntRep(objPtr);
flagPtr = NEW(NsfFlag);
assert(flagPtr != NULL);
/*fprintf(stderr, "NsfFlagObjSet allocated NsfFlag %p for %s\n", flagPtr, ObjStr(objPtr));*/
objPtr->internalRep.twoPtrValue.ptr1 = (void *)flagPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &NsfFlagObjType;
} else {
flagPtr = (NsfFlag *)objPtr->internalRep.twoPtrValue.ptr1;
assert(flagPtr != NULL);
/*fprintf(stderr, "NsfFlagObjSet %p reuses internal rep, serial (%d/%d)\n",
objPtr, flagPtr->serial, serial);*/
if (flagPtr->payload != NULL) {
DECR_REF_COUNT2("flagPtr->payload", flagPtr->payload);
}
}
/*
* add values to the structure
*/
flagPtr->signature = baseParamPtr;
flagPtr->serial = serial;
flagPtr->paramPtr = paramPtr;
flagPtr->payload = payload;
if (payload != NULL) {INCR_REF_COUNT2("flagPtr->payload", flagPtr->payload);}
flagPtr->flags = flags;
return TCL_OK;
}
Tcl_RegExp
Tcl_GetRegExpFromObj(
Tcl_Interp *interp, /* For use in error reporting, and to access
* the interp regexp cache. */
Tcl_Obj *objPtr, /* Object whose string rep contains regular
* expression pattern. Internal rep will be
* changed to compiled form of this regular
* expression. */
int flags) /* Regular expression compilation flags. */
{
int length;
TclRegexp *regexpPtr;
const char *pattern;
/*
* This is OK because we only actually interpret this value properly as a
* TclRegexp* when the type is tclRegexpType.
*/
regexpPtr = objPtr->internalRep.otherValuePtr;
if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) {
pattern = TclGetStringFromObj(objPtr, &length);
regexpPtr = CompileRegexp(interp, pattern, length, flags);
if (regexpPtr == NULL) {
return NULL;
}
/*
* Add a reference to the regexp so it will persist even if it is
* pushed out of the current thread's regexp cache. This reference
* will be removed when the object's internal rep is freed.
*/
regexpPtr->refCount++;
/*
* Free the old representation and set our type.
*/
TclFreeIntRep(objPtr);
objPtr->internalRep.otherValuePtr = regexpPtr;
objPtr->typePtr = &tclRegexpType;
}
return (Tcl_RegExp) regexpPtr;
}
void
TclInvalidateCmdLiteral(
Tcl_Interp *interp, /* Interpreter for which to invalidate a
* command literal. */
const char *name, /* Points to the start of the cmd literal
* name. */
Namespace *nsPtr) /* The namespace for which to lookup and
* invalidate a cmd literal. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name,
strlen(name), -1, NULL, nsPtr, 0, NULL);
if (literalObjPtr != NULL && literalObjPtr->typePtr == &tclCmdNameType) {
TclFreeIntRep(literalObjPtr);
}
}
int
Tcl_GetDouble(
Tcl_Interp *interp, /* Interpreter used for error reporting. */
const char *src, /* String containing a floating-point number
* in a form acceptable to
* Tcl_GetDoubleFromObj(). */
double *doublePtr) /* Place to store converted result. */
{
Tcl_Obj obj;
int code;
obj.refCount = 1;
obj.bytes = (char *) src;
obj.length = strlen(src);
obj.typePtr = NULL;
code = Tcl_GetDoubleFromObj(interp, &obj, doublePtr);
if (obj.refCount > 1) {
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
TclFreeIntRep(&obj);
return code;
}
int
Tcl_GetInt(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
const char *src, /* String containing a (possibly signed)
* integer in a form acceptable to
* Tcl_GetIntFromObj(). */
int *intPtr) /* Place to store converted result. */
{
Tcl_Obj obj;
int code;
obj.refCount = 1;
obj.bytes = (char *) src;
obj.length = strlen(src);
obj.typePtr = NULL;
code = Tcl_GetIntFromObj(interp, &obj, intPtr);
if (obj.refCount > 1) {
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
TclFreeIntRep(&obj);
return code;
}
int
Tcl_GetIndexFromObjStruct(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object containing the string to lookup. */
const void *tablePtr, /* The first string in the table. The second
* string will be at this address plus the
* offset, the third plus the offset again,
* etc. The last entry must be NULL and there
* must not be duplicate entries. */
int offset, /* The number of bytes between entries */
const char *msg, /* Identifying word to use in error
* messages. */
int flags, /* 0 or TCL_EXACT */
int *indexPtr) /* Place to store resulting integer index. */
{
int index, idx, numAbbrev;
char *key, *p1;
const char *p2;
const char *const *entryPtr;
Tcl_Obj *resultPtr;
IndexRep *indexRep;
/* Protect against invalid values, like -1 or 0. */
if (offset < (int)sizeof(char *)) {
offset = (int)sizeof(char *);
}
/*
* See if there is a valid cached result from a previous lookup.
*/
if (objPtr->typePtr == &indexType) {
indexRep = objPtr->internalRep.twoPtrValue.ptr1;
if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
*indexPtr = indexRep->index;
return TCL_OK;
}
}
/*
* Lookup the value of the object in the table. Accept unique
* abbreviations unless TCL_EXACT is set in flags.
*/
key = TclGetString(objPtr);
index = -1;
numAbbrev = 0;
/*
* Scan the table looking for one of:
* - An exact match (always preferred)
* - A single abbreviation (allowed depending on flags)
* - Several abbreviations (never allowed, but overridden by exact match)
*/
for (entryPtr = tablePtr, idx = 0; *entryPtr != NULL;
entryPtr = NEXT_ENTRY(entryPtr, offset), idx++) {
for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
if (*p1 == '\0') {
index = idx;
goto done;
}
}
if (*p1 == '\0') {
/*
* The value is an abbreviation for this entry. Continue checking
* other entries to make sure it's unique. If we get more than one
* unique abbreviation, keep searching to see if there is an exact
* match, but remember the number of unique abbreviations and
* don't allow either.
*/
numAbbrev++;
index = idx;
}
}
/*
* Check if we were instructed to disallow abbreviations.
*/
if ((flags & TCL_EXACT) || (key[0] == '\0') || (numAbbrev != 1)) {
goto error;
}
done:
/*
* Cache the found representation. Note that we want to avoid allocating a
* new internal-rep if at all possible since that is potentially a slow
* operation.
*/
if (objPtr->typePtr == &indexType) {
indexRep = objPtr->internalRep.twoPtrValue.ptr1;
} else {
TclFreeIntRep(objPtr);
indexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
objPtr->internalRep.twoPtrValue.ptr1 = indexRep;
objPtr->typePtr = &indexType;
}
indexRep->tablePtr = (void *) tablePtr;
indexRep->offset = offset;
indexRep->index = index;
*indexPtr = index;
return TCL_OK;
error:
if (interp != NULL) {
/*
* Produce a fancy error message.
*/
int count = 0;
TclNewObj(resultPtr);
Tcl_SetObjResult(interp, resultPtr);
entryPtr = tablePtr;
while ((*entryPtr != NULL) && !**entryPtr) {
entryPtr = NEXT_ENTRY(entryPtr, offset);
}
Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) &&
!(flags & TCL_EXACT) ? "ambiguous " : "bad ", msg, " \"", key,
"\": must be ", *entryPtr, NULL);
entryPtr = NEXT_ENTRY(entryPtr, offset);
while (*entryPtr != NULL) {
if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
Tcl_AppendStringsToObj(resultPtr, ((count > 0) ? "," : ""),
" or ", *entryPtr, NULL);
} else if (**entryPtr) {
Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL);
count++;
}
entryPtr = NEXT_ENTRY(entryPtr, offset);
}
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL);
}
return TCL_ERROR;
}
/*
* setFromAnyProc
*/
static int
MixinregSetFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr /* The object to convert. */
) {
NsfClass *mixin = NULL;
int oc, result;
Tcl_Obj **ov;
result = Tcl_ListObjGetElements(interp, objPtr, &oc, &ov);
if (likely(result == TCL_OK)) {
Tcl_Obj *guardObj, *nameObj;
/*
* objPtr holds a valid Tcl list
*/
if (oc == 1) {
nameObj = ov[0];
guardObj = NULL;
} else if (oc == 3 && !strcmp(ObjStr(ov[1]), NsfGlobalStrings[NSF_GUARD_OPTION])) {
nameObj = ov[0];
guardObj = ov[2];
} else {
nameObj = objPtr;
guardObj = NULL;
}
/*
* Syntax was ok. Try to lookup mixin classes:
*/
if (NsfGetClassFromObj(interp, nameObj, &mixin, 1) != TCL_OK) {
result = NsfObjErrType(interp, "mixin", nameObj, "a class as mixin", NULL);
} else {
Mixinreg *mixinRegPtr;
assert(mixin != NULL);
/*
* Conversion was ok.
* Allocate structure ...
*/
mixinRegPtr = NEW(Mixinreg);
mixinRegPtr->mixin = mixin;
mixinRegPtr->guardObj = guardObj;
/*
* ... and increment refCounts
*/
NsfObjectRefCountIncr((&mixin->object));
if (guardObj != NULL) {INCR_REF_COUNT2("mixinRegPtr->guardObj", guardObj);}
/*
* Build list of Tcl_Objs per mixin class for invalidation.
*/
{ NsfClassOpt *clOpt = NsfRequireClassOpt(mixin);
if (clOpt->mixinRegObjs == NULL) {
clOpt->mixinRegObjs = Tcl_NewListObj(1, &objPtr);
INCR_REF_COUNT2("mixinRegObjs", clOpt->mixinRegObjs);
} else {
Tcl_ListObjAppendElement(interp, clOpt->mixinRegObjs, objPtr);
}
}
/*fprintf(stderr, "MixinregSetFromAny alloc mixinReg %p class %p guard %p object->refCount %d\n",
mixinRegPtr, mixinRegPtr->mixin, mixinRegPtr->guardObj, ((&mixin->object)->refCount));*/
/*
* Free the old internal representation and store own structure as internal
* representation.
*/
TclFreeIntRep(objPtr);
objPtr->internalRep.twoPtrValue.ptr1 = (void *)mixinRegPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &NsfMixinregObjType;
}
}
return result;
}
static int
TestindexobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int allowAbbrev, index, index2, setError, i, result;
const char **argv;
static const char *const tablePtr[] = {"a", "b", "check", NULL};
/*
* Keep this structure declaration in sync with tclIndexObj.c
*/
struct IndexRep {
void *tablePtr; /* Pointer to the table of strings. */
int offset; /* Offset between table entries. */
int index; /* Selected index into table. */
};
struct IndexRep *indexRep;
if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]),
"check") == 0)) {
/*
* This code checks to be sure that the results of Tcl_GetIndexFromObj
* are properly cached in the object and returned on subsequent
* lookups.
*/
if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
return TCL_ERROR;
}
Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
indexRep = objv[1]->internalRep.otherValuePtr;
indexRep->index = index2;
result = Tcl_GetIndexFromObj(NULL, objv[1],
tablePtr, "token", 0, &index);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
if (objc < 5) {
Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", -1);
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {
return TCL_ERROR;
}
argv = ckalloc((objc-3) * sizeof(char *));
for (i = 4; i < objc; i++) {
argv[i-4] = Tcl_GetString(objv[i]);
}
argv[objc-4] = NULL;
/*
* Tcl_GetIndexFromObj assumes that the table is statically-allocated so
* that its address is different for each index object. If we accidently
* allocate a table at the same address as that cached in the index
* object, clear out the object's cached state.
*/
if (objv[3]->typePtr != NULL
&& !strcmp("index", objv[3]->typePtr->name)) {
indexRep = objv[3]->internalRep.otherValuePtr;
if (indexRep->tablePtr == (void *) argv) {
TclFreeIntRep(objv[3]);
}
}
result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index);
ckfree(argv);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}