예제 #1
0
파일: nsfObj.c 프로젝트: gustafn/nsf
/*
 *----------------------------------------------------------------------
 *
 *  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;
}
예제 #2
0
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;
}
예제 #3
0
파일: nsfObj.c 프로젝트: gustafn/nsf
/*
 * 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;
}
예제 #4
0
파일: nsfObj.c 프로젝트: gustafn/nsf
/*
 *----------------------------------------------------------------------
 *
 *  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;
}
예제 #5
0
파일: tclRegexp.c 프로젝트: afmayer/tcl-tk
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;
}
예제 #6
0
파일: tclLiteral.c 프로젝트: afmayer/tcl-tk
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);
    }
}
예제 #7
0
파일: tclGet.c 프로젝트: afmayer/tcl-tk
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;
}
예제 #8
0
파일: tclGet.c 프로젝트: afmayer/tcl-tk
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;
}
예제 #9
0
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;
}
예제 #10
0
파일: nsfObj.c 프로젝트: gustafn/nsf
/*
 * 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;
}
예제 #11
0
파일: tclTestObj.c 프로젝트: afmayer/tcl-tk
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;
}