C++ Tcl_Free函数代码示例

/** Reads a Tcl vector and returns a C vector.

    \param interp The Tcl interpreter
    \param data_in String containing a Tcl vector of doubles
    \param nrep Pointer to the C vector
    \param len Pointer to an int to store the length of the vector
    \return \em TCL_OK if everything went fine \em TCL_ERROR otherwise and 
            interp->result is set to an error message.

	    If \em TCL_OK is returned you have to make sure to free the memory
	    pointed to by nrep.
 */
int uwerr_read_tcl_double_vector(Tcl_Interp *interp, char * data_in ,
			     double ** nrep, int * len)
{
  char ** col;
  int i;

  *len = -1;

  if (Tcl_SplitList(interp, data_in, len, &col) == TCL_ERROR)
    return TCL_ERROR;

  if (*len < 1) {
    Tcl_AppendResult(interp, "Argument is not a vector.",
		     (char *)NULL);
    return TCL_ERROR;
  }

  if (!(*nrep = (double*)malloc((*len)*sizeof(double)))) {
    Tcl_AppendResult(interp, "Out of Memory.",
		     (char *)NULL);
    Tcl_Free((char *)col);
    return TCL_ERROR;
  }

  for (i = 0; i < *len; ++i) {
      if (Tcl_GetDouble(interp, col[i], &((*nrep)[i])) == TCL_ERROR) {
	Tcl_Free((char *)col);
	free(*nrep);
	return TCL_ERROR;
      }
  }

  Tcl_Free((char *)col);
  return TCL_OK;
}

// move all atoms by a given vector
int ScriptTcl::Tcl_moveallby(ClientData clientData,
	Tcl_Interp *interp, int argc, char *argv[]) {
  ScriptTcl *script = (ScriptTcl *)clientData;
  script->initcheck();
  if (argc != 2) {
    Tcl_SetResult(interp, "wrong # args", TCL_VOLATILE);
    return TCL_ERROR;
  }
  char **fstring;
  int fnum;
  double x, y, z;
  if (Tcl_SplitList(interp, argv[1], &fnum, &fstring) != TCL_OK)
    return TCL_ERROR;
  if ( (fnum != 3) ||
       (Tcl_GetDouble(interp, fstring[0],&x) != TCL_OK) ||
       (Tcl_GetDouble(interp, fstring[1],&y) != TCL_OK) ||
       (Tcl_GetDouble(interp, fstring[2],&z) != TCL_OK) ) {
    Tcl_SetResult(interp,"argument not a vector",TCL_VOLATILE);
    Tcl_Free((char*)fstring);
    return TCL_ERROR;
  }
  Tcl_Free((char*)fstring);

  MoveAllByMsg *msg = new MoveAllByMsg;
  msg->offset = Vector(x,y,z);
  (CProxy_PatchMgr(CkpvAccess(BOCclass_group).patchMgr)).moveAllBy(msg);

  script->barrier();
  return TCL_OK;
}

/* Exposed as private function to librt, but not (currently) beyond librt -
 * see librt_private.h */
int
tcl_list_to_avs(const char *tcl_list, struct bu_attribute_value_set *avs, int offset)
{
    int i = 0;
    int list_c = 0;
    const char **listv = (const char **)NULL;

    if (Tcl_SplitList(NULL, tcl_list, &list_c, (const char ***)&listv) != TCL_OK) {
	return -1;
    }

    if (!BU_AVS_IS_INITIALIZED(avs)) BU_AVS_INIT(avs);

    if (!list_c) {
	Tcl_Free((char *)listv);
	return 0;
    }

    if (list_c > 2) {
	for (i = offset; i < list_c; i += 2) {
	    (void)bu_avs_add(avs, listv[i], listv[i+1]);
	}
    } else {
	return -1;
    }

    Tcl_Free((char *)listv);
    return 0;
}

/* 
 *  Syslog_Delete - Tcl_CmdDeleteProc for syslog command.
 *  Frees all hash tables and closes log if it was opened.
 */
static void Syslog_Delete(ClientData data)
{ SyslogInfo *info=(SyslogInfo *)data;
  Tcl_DeleteHashTable(info->facilities);
  Tcl_Free((char *)info->facilities);
  Tcl_DeleteHashTable(info->priorities);
  Tcl_Free((char *)info->priorities);
  if (info->logOpened) {
     closelog();
  }
  Tcl_Free((char *)info);
}

int ARecDelInst(ClientData data)
{
        ARecField *inst = (ARecField *) data;

    Tcl_DecrRefCount(inst->nameobj);

    ARecFreePointers(inst, inst->recs);

    Tcl_Free((void *) inst->recs);
    Tcl_Free((void *) inst);

    return TCL_OK;
}

static void
QueryConfigDelete(
    ClientData clientData)
{
    QCCD *cdPtr = clientData;
    Tcl_Obj *pkgName = cdPtr->pkg;
    Tcl_Obj *pDB = GetConfigDict(cdPtr->interp);

    Tcl_DictObjRemove(NULL, pDB, pkgName);
    Tcl_DecrRefCount(pkgName);
    if (cdPtr->encoding) {
	Tcl_Free(cdPtr->encoding);
    }
    Tcl_Free(cdPtr);
}

/****
 * implementation of list2shape (creates RFshape from a list { {a p} {a p} ... }
 ****/
int tclList2Shape(ClientData data,Tcl_Interp* interp,int argc, char *argv[])
{
  char **list1, **list2;
  int nlist1, nlist2, i, slot;
  
  if (argc != 2)
    return TclError(interp,"Usage: <RFshape> list2shape { {a1 p1} {a2 p2} ... }");

  if (Tcl_SplitList(interp,argv[1],&nlist1,&list1) != TCL_OK)
     return TclError(interp,"list2shape: unable to decompose list argument");

  /* get a new slot and allocate */
  slot = RFshapes_slot();
  if (slot == -1) {
     Tcl_Free((char *)list1);
     return TclError(interp,"list2shape error: no more free slots available, free some shape first!");
  }
  RFshapes[slot] = RFshapes_alloc(nlist1);


  for (i=0; i<nlist1; i++) {
     if (Tcl_SplitList(interp,list1[i],&nlist2,&list2) != TCL_OK) {
          Tcl_Free((char *)list1);
          return TclError(interp,"list2shape can not read list element %d",i+1);
     }
     if (nlist2 != 2) {
        Tcl_Free((char *)list1);
        Tcl_Free((char *)list2);
        return TclError(interp,"list2shape: expecting two elements like {amplitude phase} in list");
     }
     if (Tcl_GetDouble(interp,list2[0],&RFshapes[slot][i+1].ampl) != TCL_OK) {
        Tcl_Free((char *)list1);
        Tcl_Free((char *)list2); 
        return TclError(interp,"lis2shape cannot interpret amplitude in element %d",i+1);
     }
     if (Tcl_GetDouble(interp,list2[1],&RFshapes[slot][i+1].phase) != TCL_OK) {
        Tcl_Free((char *)list1);
        Tcl_Free((char *)list2); 
        return TclError(interp,"lis2shape cannot interpret phase in element %d",i+1);
     }
     Tcl_Free((char *)list2);  
  }
  Tcl_Free((char *)list1);

  sprintf(interp->result,"%d",slot);

  return TCL_OK;
}

/* 
 * Provide user feedback and warnings beyond result values.
 * If we are running interactively, Tcl_Main will take care of echoing results
 * to the console.  If we run a script, we need to output the results
 * ourselves.
 */
void newhandle_msg(void *v, const char *msg) {
  Tcl_Interp *interp = (Tcl_Interp *)v;
  const char *words[3] = {"puts", "-nonewline", "psfgen) "};
  char *script = NULL;
  
  // prepend "psfgen) " to all output 
  script = Tcl_Merge(3, words);
  Tcl_Eval(interp,script); 
  Tcl_Free(script);

  // emit the output
  words[1] = msg;
  script = Tcl_Merge(2, words);
  Tcl_Eval(interp,script);
  Tcl_Free(script);
}

/*
 * Sets an active tag array from the 'list' string.
 * An empty 'list' sets the array to contain nothing, but a NULL list sets
 * the array to the default - all.
 */
int SetActiveTags2 (char *list, int *num, char ***types) {
    if (*types)
	Tcl_Free((char *)*types);
 
    if (list) {
	if (SplitList(list, num, types) == -1) {
	    *types = NULL;
	    *num = 0;
	    return -1;
	}
    } else {
	int i;

	if (NULL == (*types = (char **)Tcl_Alloc(tag_db_count * sizeof(char *)))){
	    *num = 0;
	    return -1;
	}

	for (i = 0; i < tag_db_count; i++) {
	    (*types)[i] = tag_db[i].id;
	}
	*num = tag_db_count;
    }

    return 0;
}

void                
Tfp_ArrayDestroy( Tfp_ArrayType *arr )
{
    Tcl_HashEntry   *p;
    Tcl_HashSearch  s;
    
    if (arr->cleanProc != (Tfp_ArrayDeleteProc *) NULL) {
        for (p = Tcl_FirstHashEntry( arr->table, &s ); p != (Tcl_HashEntry *) NULL;
                p = Tcl_NextHashEntry( &s )) {
            (*arr->cleanProc) ( Tcl_GetHashValue( p ) );
        }
    }
    Tcl_DeleteHashTable( arr->table );
    Tcl_Free( (char *) arr->table );
    Tcl_Free( (char *) arr );
}

/* Fill a preallocated vector arguments, doing expansion and all.
 * Assumes Tcl will
 *  not tamper with our strings
 *  make copies if strings are "persistent"
 */
int fill_args (char **argv, int where, value v)
{
  value l;

  switch (Tag_val(v)) {
  case 0:
    argv[where] = caml_string_to_tcl(Field(v,0)); /* must free by stat_free */
    return (where + 1);
  case 1:
    for (l=Field(v,0); Is_block(l); l=Field(l,1))
      where = fill_args(argv,where,Field(l,0));
    return where;
  case 2:
    { char **tmpargv;
      char *merged;
      int i;
      int size = argv_size(Field(v,0));
      tmpargv = (char **)stat_alloc((size + 1) * sizeof(char *));
      fill_args(tmpargv,0,Field(v,0));
      tmpargv[size] = NULL;
      merged = Tcl_Merge(size,tmpargv);
      for(i = 0; i<size; i++){ stat_free(tmpargv[i]); }
      stat_free((char *)tmpargv);
      /* must be freed by stat_free */
      argv[where] = (char*)stat_alloc(strlen(merged)+1);
      strcpy(argv[where], merged);
      Tcl_Free(merged);
      return (where + 1);
    }
  default:
    tk_error("fill_args: illegal tag");
  }
}

static int
rcClose (ClientData cd_, Tcl_Interp* interp)
{
  ReflectingChannel* chan = (ReflectingChannel*) cd_;
  int n = -1;

  Tcl_SavedResult sr;
  Tcl_Obj* cmd = rcBuildCmdList(chan, Tcl_NewStringObj("close", -1));
  Tcl_Interp* ip = chan->_interp;

  Tcl_SaveResult(ip, &sr);

  if (Tcl_EvalObjEx(ip, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT) == TCL_OK)
    Tcl_GetIntFromObj(NULL, Tcl_GetObjResult(ip), &n);

  Tcl_RestoreResult(ip, &sr);
  Tcl_DecrRefCount(cmd);

  if (chan->_timer != NULL) {
    Tcl_DeleteTimerHandler(chan->_timer);
    chan->_timer = NULL;
  }

  Tcl_DecrRefCount(chan->_context);
  Tcl_DecrRefCount(chan->_seek);
  Tcl_DecrRefCount(chan->_read);
  Tcl_DecrRefCount(chan->_write);
  Tcl_DecrRefCount(chan->_name);
  Tcl_Free((char*) chan);

  return TCL_OK;
}

pure_expr *tk_join(pure_expr *x)
{
  size_t i, n;
  pure_expr **xv;
  if (pure_is_listv(x, &n, &xv)) {
    char *s, *ret;
    char **argv = (char**)malloc(n*sizeof(char*));
    pure_expr *x;
    for (i = 0; i < n; i++) {
      x = xv[i];
      if (pure_is_string_dup(x, &s))
	argv[i] = s;
      else {
	size_t j;
	for (j = 0; j < i; j++) free(argv[j]);
	free(argv);
	free(xv);
	return NULL;
      }
    }
    free(xv);
    ret = Tcl_Merge(n, (const char**)argv);
    for (i = 0; i < n; i++) free(argv[i]);
    free(argv);
    x = pure_string_dup(ret);
    Tcl_Free(ret);
    return x;
  } else
    return NULL;
}

/*
** release the memory successfully allocated for an audio tap
*/
static void _delete_impl(_t *data) {
  if (data->buffs != NULL) {
    for (int i = 0; i < data->buff_n; i += 1) {
      if (data->buffs[i].buff != NULL)
	Tcl_DecrRefCount(data->buffs[i].buff);
    }
    Tcl_Free((char *)data->buffs);
  }
}

/*
** Called when the command is deleted.
*/
static void DbDeleteCmd(void *db){
  SqliteDb *pDb = (SqliteDb*)db;
  sqlite_close(pDb->db);
  while( pDb->pFunc ){
    SqlFunc *pFunc = pDb->pFunc;
    pDb->pFunc = pFunc->pNext;
    Tcl_Free((char*)pFunc);
  }
  if( pDb->zBusy ){
    Tcl_Free(pDb->zBusy);
  }
  if( pDb->zTrace ){
    Tcl_Free(pDb->zTrace);
  }
  if( pDb->zAuth ){
    Tcl_Free(pDb->zAuth);
  }
  Tcl_Free((char*)pDb);
}