C++ Tcl_VarEval函数代码示例

int announce_error(int code, char *command)
{
	if (code != TCL_OK) {
                char buf[128];
#ifdef WIN32
                DWORD dwMBResponse;
                char *szFmt="Sdr failed with the following error:\n\n%s %s\n\nPlease report to [email protected]\n\nContinue running application?", *szErrMsg;   
                DWORD dwErrMsgLen = strlen(command) + strlen(interp->result) + strlen(szFmt);
                
                szErrMsg = (char*)malloc(dwErrMsgLen);
                sprintf(szErrMsg, szFmt, command, interp->result);
                dwMBResponse = MessageBox(NULL, szErrMsg, "SDR Error", MB_ICONERROR|MB_YESNO);
                free(szErrMsg);
                if (dwMBResponse == IDNO) {
                        exit(-1);
                }       
#else
                fprintf(stderr, "sdr:%s %s\n", command, interp->result);
#endif
                Tcl_VarEval(interp, "puts $errorInfo", NULL);
                strncpy(buf, interp->result, sizeof(buf) - 1);
                buf[sizeof(buf) - 1] = 0; /* Let's not overrun */
        	Tcl_VarEval(interp, "tkerror {", buf, "}", NULL);	        
	}
	return (code);
}

void seqed_shutdown(Tcl_Interp *interp,
		    SeqedResult *result)
{
    Tcl_CmdInfo info;
    tkSeqed *se;
    char *tmp;

#ifdef DEBUG
    printf("seqed shutdown \n");
#endif

    Tcl_GetCommandInfo(interp, result->seqed_win, &info);
    se = (tkSeqed*)info.clientData;

   if (se->renzDisplayed) {
	free_lines();
	free_r_enzyme(se->r_enzyme, se->num_enzymes);
    }

    /* destroy toplevel seqed window */
    Tcl_VarEval(interp, "winfo toplevel ", result->seqed_win, NULL);
    Tcl_VarEval(interp, "destroy ", Tcl_GetStringResult(interp), NULL);

    tmp = get_default_string(interp, tk_utils_defs, w("RASTER.RESULTS.WIN"));
    if (TCL_OK != Tcl_VarEval(interp, "seq_result_list_update ", 
			      tmp, NULL)){
	verror(ERR_WARN, "seqed shutdown", "%s \n", Tcl_GetStringResult(interp));
    }

    xfree(result);
}

/*
 * Remove a result from the csplot window
 */
void csmatch_remove(GapIO *io, char *cs_plot,
                    mobj_repeat *reg_dat,
                    HTablePtr T[]) {
    int c;

    /* Delete from the canvas and hash table */
    DeleteRepeats(GetInterp(), reg_dat, cs_plot, T);

    /*
     * Remove from the registration lists.
     * Loop through all contigs for time being.
     */
    for (c = 1; c <= NumContigs(io); c++)
        contig_deregister(io, c, reg_dat->reg_func, reg_dat);

    /*
     * Pop down configuration window if visible
     */
    if (TCL_OK != Tcl_VarEval(GetInterp(), "cs_config_quit ", cs_plot, " ",
                              reg_dat->tagname, NULL)) {
        puts(GetInterpResult());
    }

    /* Inform contig selector next button */
    Tcl_VarEval(GetInterp(), "CSLastUsedFree ", CPtr2Tcl(reg_dat), NULL);

    /* Free memory */
    if (reg_dat->match)
        xfree(reg_dat->match);
    if (reg_dat->params)
        xfree(reg_dat->params);
    xfree(reg_dat);
}

//-------------------------------------------------------------------------
void Prg_ASCEND::slv_iterate(slv_system_t, SlvClientToken clt)
{
  //fprintf(stderr, "Prg_ASCEND::slv_iterate called\n");

  Hqp_SqpSolver *sqp = (Hqp_SqpSolver *)clt;
  Prg_ASCEND *prg = (Prg_ASCEND *)sqp->prg();
  // todo: assert prg != NULL && prg->name() == "ASCEND"

  // currently call Tcl command hqp_solve
  // todo: replace with calls to sqp->{qp_update, qp_solve, step}()
  extern Tcl_Interp *theInterp;
  char *tcl_channel = "stdout";
  sqp->set_max_iters(sqp->iter() + 1);	// allow one iteration
  if (Tcl_VarEval(theInterp, "hqp_solve ", tcl_channel, NULL) == TCL_OK) {
    prg->_slv_status.converged = TRUE;
    prg->_slv_status.ready_to_solve = FALSE;
  }
  else if (strcmp(theInterp->result, "iters") != 0) {
    prg->_slv_status.ok = FALSE;
    prg->_slv_status.ready_to_solve = FALSE;
    Tcl_VarEval(theInterp, "puts ", tcl_channel,
		" \"HQP Error: ", theInterp->result, "\"", NULL);
  }

  prg->_slv_status.iteration = sqp->iter();
}

void nip_string_search_shutdown(Tcl_Interp *interp,
				seq_result *result,
				char *raster_win,
				int seq_num)
{
    in_string_search *input = result->input;
    stick *data = result->data;
    out_raster *output = result->output;
    char *tmp;
    seq_reg_key_name info;
    static char buf[80];
    int raster_id;
    RasterResult *raster_result;

    /* determine raster_id and raster_result structure */
    Tcl_VarEval(interp, "GetRasterId ", raster_win, NULL);
    raster_id = atoi(Tcl_GetStringResult(interp));
    raster_result = raster_id_to_result(raster_id);

    /* find key name BEFORE deregister */
    info.job = SEQ_KEY_NAME;
    info.line = buf;
    seq_result_notify(result->id, (seq_reg_data *)&info, 0);

    seq_deregister(seq_num, nip_string_search_callback, 
		   (seq_result *)result);
		
    /* 
     * only bother replotting the raster if there are still results in the
     * raster
     */
    if (raster_result && raster_result->num_results > 1) {
	ReplotAllCurrentZoom(interp, raster_win);
	tmp = get_default_string(interp, tk_utils_defs, 
				 w("RASTER.RESULTS.WIN"));
	if (TCL_OK != Tcl_VarEval(interp, "seq_result_list_update ", 
				  tmp, NULL)){
	    puts(Tcl_GetStringResult(interp));
	}
	
	if (TCL_OK != Tcl_VarEval(interp, "RemoveRasterResultKey ", raster_win,
				  " {", info.line, "}", NULL))
	    verror(ERR_WARN, "string_search", "shutdown %s \n", Tcl_GetStringResult(interp));
    }
    xfree(data->ap_array[0].p_array);
    xfree(data->ap_array);
    xfree(data);

    free(input->params);
    free(input->string);
    xfree(result->input);
    xfree(output->configure[0]);
    xfree(output->configure);
    xfree(result->output);

    xfree(result);

    if (raster_result) 
	DeleteResultFromRaster(raster_result);    
}

static void tout_update_stream(int fd, const char *buf, int header,
			       const char *tag) {
    char * win;
    char tag_list[1024];

    if (!win_init) {
#ifdef _WIN32
	/* WINNT will not have stdout/err defined unless running in console mode
	 * so use a message box
	 */
	if( fileno(stdout) == -1 || fileno(stderr) == -1 ){
	    MessageBox(NULL,buf,"Error",MB_OK|MB_ICONERROR|MB_TASKMODAL);
	    return;
	}
#endif
	fprintf(fd == 1 ? stdout : stderr, "%s", buf);
	fflush(fd == 1 ? stdout : stderr);
	return;
    }

    win = fd == 1 ? stdout_win : stderr_win;

    /* Add to the redirection streams */
    if (fd == 1 && stdout_fp) {
	fprintf(stdout_fp, "%s", buf);
	fflush(stdout_fp);
    } else if (fd == 2 && stderr_fp) {
	fprintf(stderr_fp, "%s", buf);
	fflush(stderr_fp);
    }

    if (info_win) {
	Tcl_DStringAppend(&message, buf, strlen(buf));
    }

    if (tag) {
	sprintf(tag_list, "{%s%s %s}",
		cur_tag, header ? "_h" : "_t",
		tag);
    } else {
	sprintf(tag_list, "%s%s", cur_tag, header ? "_h" : "_t");
    }

    /* Add to the text widget */
    if (win_init) {
	Tcl_SetVar(_interp, "TEMP", buf, 0);

	Tcl_VarEval(_interp, win, " insert end ", "\"$TEMP\" ",
		    tag_list, NULL);

	if (fd == 1 ? stdout_scroll : stderr_scroll) {
	    /* scroll to bottom of output window */
	    Tcl_VarEval(_interp, win, " see end", NULL);
	}
    }
}

void deleteTraceDisplay(edview *xx, DisplayContext *dc) {
    char buf[1024];
    tman_dc *edc;
    int i, num = -1;
    int mini_trace;

    if (!dc)
	return;

    for (i = 0; i < MAXCONTEXTS; i++) {
	if (context_list[i] >= 0 && &contexts[context_list[i]] == dc) {
	    num = i;
	    break;
	}
    }
    
    mini_trace = dc->mini_trace;

    /* Remove num and shuffle remaining items down */
    if ((edc = find_edc(dc)) && !mini_trace)
	tman_unhighlight(edc);

    dc->used = 0;
    strcpy(buf, dc->path);

    /*
     * This order is important. If we destroy the widget before removing
     * it from the context list then it will be destroyed twice, as there is
     * a <Destroy> binding on the widget would call (eventually) this code
     * again.
     */
    if (num < MAXCONTEXTS-1) {
	memmove(&context_list[num], &context_list[num+1],
		sizeof(int) * (MAXCONTEXTS-1 - num));
    }
    context_list[MAXCONTEXTS-1] = -1;

    if (mini_trace) {
	/* Mini traces are just a dnatrace widget */
	Tcl_VarEval(EDINTERP(xx->ed), "destroy ", buf, NULL);
    } else {
	/*
	 * Full traces are a complex of windows, of with dc->path is a child.
	 * So we destroy the parent instead.
	 */
	Tcl_VarEval(EDINTERP(xx->ed), "dnatrace_remove ", buf, NULL);
    }
}

void SeqRasterPlotFunc(Tk_Raster *raster,
		       char *raster_win,
		       int job,
		       int x0, int y0,
		       int x1, int y1)
{

    switch (job) {
    case RASTER_INIT: 
	{
	    int num_elements;
	    seq_result **data;
	    seq_result *result;
	    int num_funcs;
	    out_raster *output;
	    RasterResult *raster_result;
	    int raster_id;
   
	    num_elements = seq_num_results();
	    if (num_elements == 0)
		return;
	    
	    data = (seq_result **)xmalloc(num_elements * sizeof(seq_result *));
	    if (-1 == search_reg_data(comparison2, (void **)data, &num_funcs)){
		xfree(data);
		return;	
	    }
	    if (num_funcs == 0) {
		xfree(data);
		return;
	    }
    
	    result = data[0];
	    output = result->output;

	    Tcl_VarEval(output->interp, "GetRasterId ", raster_win, NULL);
	    raster_id = atoi(Tcl_GetStringResult(output->interp));

	    if (NULL == (raster_result = raster_id_to_result(raster_id))) {
		xfree(data);
		return;
	    }
	    
	    remove_all_raster_cursors(output->interp, raster, raster_result);
	    xfree(data);

	    break;
	}
    case RASTER_REPLOT_ALL:
	SeqReplotResults(raster, raster_win, 1, 0, x0, y0, x1, y1);
	break;
    case RASTER_REPLOT_SLIVER:
	SeqReplotResults(raster, raster_win, 0, 0, x0, y0, x1, y1);
	break;
    case RASTER_REPLOT_ZOOM:
	/* NOTE: this is different in nip4 */
	SeqReplotResults(raster, raster_win, 0, 1, x0, y0, x1, y1);
	break;
    }
}

int tcl_parse_jump(char *from, char *rest, Hook *hook)
{
	Tcl_Obj	*tcl_result;
	int	i;

#ifdef DEBUG
	debug("(tcl_parse_jump) %s %s %s\n",
		nullstr(hook->self),nullstr(from),nullstr(rest));
#endif /* DEBUG */

	if (from)
		nickcpy(CurrentNick,from);
	else
		*CurrentNick = 0;

	Tcl_SetVar(energymech_tcl,"_from",from,0);
	Tcl_SetVar(energymech_tcl,"_rest",rest,0);

	i = 0;
	if (Tcl_VarEval(energymech_tcl,hook->self," $_from $_rest",NULL) == TCL_OK)
	{
		tcl_result = Tcl_GetObjResult(energymech_tcl);
		Tcl_GetIntFromObj(energymech_tcl,tcl_result,&i);
	}
#ifdef DEBUG
	if (energymech_tcl->result && *energymech_tcl->result)
		debug("(tcl_parse_jump) result = %s\n",nullstr(energymech_tcl->result));
#endif /* DEBUG */
	return(i);
}

//-----------------------------------------------------------------------
extern "C" int If_SetInt(const char *name, int val)
{
  if (!theInterp)
    return IF_ERROR;

#if 0
  // unfortunately Tcl_EvalObjv was not available under Tcl 8.0
  Tcl_Obj *objv[2];

  objv[0] = Tcl_NewStringObj((char *)name, -1);
  objv[1] = Tcl_NewIntObj(val);

  int retcode;
  retcode = Tcl_EvalObjv(theInterp, 2, objv, 0);

  Tcl_DecrRefCount(objv[0]);
  Tcl_DecrRefCount(objv[1]);

  if (retcode != TCL_OK)
    return IF_ERROR;
#else
  char valstr[50];
  sprintf(valstr, "%d", val);
  if (Tcl_VarEval(theInterp, (char *)name, " ", valstr, NULL) != TCL_OK)
    return IF_ERROR;
#endif

  Tcl_ResetResult(theInterp); // reset result as val was accepted
  return IF_OK;
}

/* Trigger (execute) a Tcl proc
 *
 * Note: This is INLINE code for check_tcl_bind().
 */
static inline int trigger_bind(const char *proc, const char *param,
                               char *mask)
{
  int x;

  Tcl_SetVar(interp, "lastbind", (char *) mask, TCL_GLOBAL_ONLY);
  x = Tcl_VarEval(interp, proc, param, NULL);

  if (x == TCL_ERROR) {
    /* FIXME: we really should be able to log longer errors */
    if (strlen(interp->result) > 400)
      interp->result[400] = 0;

    putlog(LOG_MISC, "*", "Tcl error [%s]: %s", proc, interp->result);

    return BIND_EXECUTED;
  }

  /* FIXME: This is an ugly hack. It is not documented as a
   *        'feature' because it will eventually go away.
   */
  if (!strcmp(interp->result, "break"))
    return BIND_QUIT;

  return (atoi(interp->result) > 0) ? BIND_EXEC_LOG : BIND_EXECUTED;
}

void nip_stop_codons_shutdown(Tcl_Interp *interp,
			      seq_result *s_result,
			      element *e,
			      int seq_num)
{
    in_s_codon *input = s_result->input;
    seq_reg_key_name info;
    static char buf[80];

#ifdef DEBUG
    printf("nip_stop_codons_shutdown\n");
#endif

    /* find key name BEFORE deregister */
    info.job = SEQ_KEY_NAME;
    info.line = buf;
    seq_result_notify(s_result->id, (seq_reg_data *)&info, 0);

    seq_deregister(seq_num, nip_stop_codons_callback, (seq_result *)s_result);

    Tcl_VarEval(e->c->interp, "result_list_update ", e->c->win, NULL);

    if (e->num_results > 0) {
	e->replot_func(e);
    }

    free(input->params);
    xfree(s_result->input);
    xfree(s_result);
}

int Viewimage_Init(Tcl_Interp *interp) {
	/* initialize the stub table interface */
	if (Tcl_InitStubs(interp,"8.1",0)==NULL) {
		return TCL_ERROR;
	}
	if (Tk_InitStubs(interp,"8.1",0)==NULL) {
		return TCL_ERROR;
	}
	if (Tcl_PkgRequire(interp,"Tk","8.1",0)==NULL) {
		return TCL_ERROR;
	}
	if (Tcl_PkgRequire(interp,"mvthimage","1.0",0)==NULL) {
		return TCL_ERROR;
	}
	
	/* initialize the new, alternative image context handling code */
	MvthImageState_Init(interp);

	/* Initialize the Tcl script for viewing images in a Tk window.*/
	char buff[1024];
	snprintf(buff,sizeof(buff),"%s/viewimage.tcl",TCLSCRIPTDIR);
	fprintf(stdout,"viewimage.tcl should be located at: %s\n",buff);
	Tcl_EvalFile(interp,buff);
	Tcl_VarEval(interp,
			"puts stdout {viewimage Copyright (C) 2009 Sam Bromley};",
			"puts stdout {This software comes with ABSOLUTELY NO WARRANTY.};",
			"puts stdout {This is free software, and you are welcome to};",
			"puts stdout {redistribute it under certain conditions.};",
			"puts stdout {For details, see the GNU Lesser Public License V.3 <http://www.gnu.org/licenses>.};",
			NULL);
	Tcl_VarEval(interp,
			"proc miexpand {w} {"
				"foreach {wo ho do bo} [mi size $w] break;"
				"set c [::viewimage::canvasNameFromImg $w];"
				"set wi [winfo width $c];"
				"set hi [winfo height $c];"
				"set wi [expr {$wi-3}];"
				"set hi [expr {$hi-3}];"
				"if {$wi<=0} {set wi 10};"
				"if {$hi<=0} {set hi 10};"
				"mi size $w [list $wi $hi $bo];"
				"xblitimage $w;"
			"}",NULL);
	/* Declare that we provide the buriedtargets package */
	Tcl_PkgProvide(interp,"viewimage","1.0");
	return TCL_OK;
}

static int tcl_setchan(ClientData cd, Tcl_Interp *irp,
                       int argc, char *argv[])
{
  int idx, chan;
  module_entry *me;

  BADARGS(3, 3, " idx channel");

  idx = findidx(atoi(argv[1]));
  if (idx < 0 || (dcc[idx].type != &DCC_CHAT &&
      dcc[idx].type != &DCC_SCRIPT)) {
    Tcl_AppendResult(irp, "invalid idx", NULL);
    return TCL_ERROR;
  }
  if (argv[2][0] < '0' || argv[2][0] > '9') {
    if (!strcmp(argv[2], "-1") || !egg_strcasecmp(argv[2], "off"))
      chan = -1;
    else {
      Tcl_SetVar(irp, "chan", argv[2], 0);
      if (Tcl_VarEval(irp, "assoc ", "$chan", NULL) != TCL_OK ||
          !interp->result[0]) {
        Tcl_AppendResult(irp, "channel name is invalid", NULL);
        return TCL_ERROR;
      }
      chan = atoi(interp->result);
    }
  } else
    chan = atoi(argv[2]);
  if ((chan < -1) || (chan > 199999)) {
    Tcl_AppendResult(irp, "channel out of range; must be -1 through 199999",
                     NULL);
    return TCL_ERROR;
  }
  if (dcc[idx].type == &DCC_SCRIPT)
    dcc[idx].u.script->u.chat->channel = chan;
  else {
    int oldchan = dcc[idx].u.chat->channel;

    if (dcc[idx].u.chat->channel >= 0) {
      if ((chan >= GLOBAL_CHANS) && (oldchan < GLOBAL_CHANS))
        botnet_send_part_idx(idx, "*script*");
      check_tcl_chpt(botnetnick, dcc[idx].nick, dcc[idx].sock,
                     dcc[idx].u.chat->channel);
    }
    dcc[idx].u.chat->channel = chan;
    if (chan < GLOBAL_CHANS)
      botnet_send_join_idx(idx, oldchan);
    check_tcl_chjn(botnetnick, dcc[idx].nick, chan, geticon(idx),
                   dcc[idx].sock, dcc[idx].host);
  }
  /* Console autosave. */
  if ((me = module_find("console", 1, 1))) {
    Function *func = me->funcs;

    (func[CONSOLE_DOSTORE]) (idx);
  }
  return TCL_OK;
}

void funcparams(char *params) {

     if (win_init) {
	 Tcl_VarEval(_interp, "tout_tag_params ",
		     stdout_win,
		     " ", cur_tag,
		     " {", params, "}", NULL);
     }
 }