enum MqErrorE NS(FactoryCreate) (
struct MqS * const tmpl,
enum MqFactoryE create,
struct MqFactoryS * const item,
struct MqS ** contextP
) {
struct MqS * mqctx = NULL;
Tcl_Interp * interp;
if (create == MQ_FACTORY_NEW_THREAD) {
interp = Tcl_CreateInterp();
TclErrorToCtxWithReturn (tmpl, Tcl_Init(interp))
Tcl_SetVar (interp, "MQ_STARTUP_IS_THREAD", "yes", TCL_GLOBAL_ONLY);
TclErrorToCtxWithReturn (tmpl, Tcl_EvalFile(interp, MqInitGetArg0()->data[1]->cur.C))
} else if (create == MQ_FACTORY_NEW_INIT) {
void load_tux()
{
char cwd[BUFF_LEN];
if ( tuxLoaded == True )
return;
tuxLoaded = True;
registerHierCallbacks( g_game.tcl_interp );
register_tux_callbacks( g_game.tcl_interp );
initialize_scene_graph();
if ( getcwd( cwd, BUFF_LEN ) == NULL ) {
handle_system_error( 1, "getcwd failed" );
}
if ( chdir( getparam_data_dir() ) != 0 ) {
/* Print a more informative warning since this is a common error */
handle_system_error(
1, "Can't find the tuxracer data "
"directory. Please check the\nvalue of `data_dir' in "
"~/.tuxracer/options and set it to the location where you\n"
"installed the TRWC-data files.\n\n"
"Couldn't chdir to %s", getparam_data_dir() );
/*
handle_system_error( 1, "couldn't chdir to %s", getparam_data_dir() );
*/
}
if ( Tcl_EvalFile( g_game.tcl_interp, "tux.tcl") == TCL_ERROR ) {
handle_error( 1, "error evalating %s/tux.tcl: %s\n"
"Please check the value of `data_dir' in ~/.tuxracer/options "
"and make sure it\npoints to the location of the "
"latest version of the TRWC-data files.",
getparam_data_dir(),
Tcl_GetStringResult( g_game.tcl_interp ) );
}
check_assertion( !Tcl_InterpDeleted( g_game.tcl_interp ),
"Tcl interpreter deleted" );
if ( chdir( cwd ) != 0 ) {
handle_system_error( 1, "couldn't chdir to %s", cwd );
}
}
void tclpd_setup(void) {
if(tclpd_interp) {
return;
}
/* verbose(-1) post to the pd window at level 3 */
verbose(-1, "tclpd loader v" TCLPD_VERSION);
/* kludge to work around tclpd messing up the loading of UTF-8 patches. This
* should really be solved correctly, its probably caused by the
* locale/encoding not being setup correctly, perhaps in pd itself */
#if defined __gnu_linux__ || defined __GNU__ || defined __FreeBSD_kernel__
char *lang = getenv("LANG");
setenv("LANG", "C", 1);
#endif
proxyinlet_setup();
tclpd_interp = Tcl_CreateInterp();
Tcl_Init(tclpd_interp);
Tclpd_SafeInit(tclpd_interp);
#if defined __gnu_linux__ || defined __GNU__ || defined __FreeBSD_kernel__
setenv("LANG", lang, 1);
#endif
Tcl_Eval(tclpd_interp, "package provide Tclpd " TCLPD_VERSION);
t_class *foo_class = class_new(gensym("tclpd_init"), 0, 0, 0, 0, 0);
char buf[PATH_MAX];
snprintf(buf, PATH_MAX, "%s/tclpd.tcl", foo_class->c_externdir->s_name);
verbose(-1, "tclpd: trying to load %s...", buf);
int result = Tcl_EvalFile(tclpd_interp, buf);
switch(result) {
case TCL_ERROR:
error("tclpd: error loading %s", buf);
break;
case TCL_RETURN:
error("tclpd: warning: %s exited with code return", buf);
break;
case TCL_BREAK:
case TCL_CONTINUE:
error("tclpd: warning: %s exited with code break/continue", buf);
break;
}
verbose(-1, "tclpd: loaded %s", buf);
sys_register_loader(tclpd_do_load_lib);
}
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 enum MqErrorE NS(FactoryCreate) (
struct MqS * const tmpl,
enum MqFactoryE create,
MQ_PTR data,
struct MqS ** contextP
) {
struct MqBufferS * const buf = tmpl->temp;
struct MqS * mqctx = *contextP = MqContextCreate (sizeof(struct TclContextS), tmpl);
SETUP_tclctx
Tcl_Interp * interp;
if (create == MQ_FACTORY_NEW_THREAD) {
interp = Tcl_CreateInterp();
TclErrorToMq (Tcl_Init(interp))
Tcl_SetVar (interp, "MQ_STARTUP_IS_THREAD", "yes", TCL_GLOBAL_ONLY);
TclErrorToMq (Tcl_EvalFile(interp, MqInitBuf->data[1]->cur.C))
} else {
rpmRC rpmtclRunFile(rpmtcl tcl, const char * fn, const char ** resultp)
{
rpmRC rc = RPMRC_FAIL;
if (_rpmtcl_debug)
fprintf(stderr, "==> %s(%p,%s)\n", __FUNCTION__, tcl, fn);
if (tcl == NULL) tcl = rpmtclI();
#if defined(WITH_TCL)
if (fn != NULL && Tcl_EvalFile((Tcl_Interp *)tcl->I, fn) == TCL_OK) {
rc = RPMRC_OK;
if (resultp)
*resultp = rpmiobStr(tcl->iob);
}
#endif
return rc;
}
/// parseTclFile - reads a tcl configuration file and initialize the legupConfig
/// object. Returns false on error.
bool parseTclFile(std::string &ConfigFile, LegupConfig *legupConfig) {
Tcl_Interp *interp = Tcl_CreateInterp();
assert(interp);
Tcl_CreateCommand(interp, "set_accelerator_function",
set_accelerator_function, legupConfig, 0);
Tcl_CreateCommand(interp, "set_parallel_accelerator_function",
set_parallel_accelerator_function, legupConfig, 0);
Tcl_CreateCommand(interp, "set_dcache_size",
set_dcache_size, legupConfig, 0);
Tcl_CreateCommand(interp, "set_dcache_linesize",
set_dcache_linesize, legupConfig, 0);
Tcl_CreateCommand(interp, "set_dcache_way",
set_dcache_way, legupConfig, 0);
Tcl_CreateCommand(interp, "set_icache_size",
set_icache_size, legupConfig, 0);
Tcl_CreateCommand(interp, "set_icache_linesize",
set_icache_linesize, legupConfig, 0);
Tcl_CreateCommand(interp, "set_icache_way",
set_icache_way, legupConfig, 0);
Tcl_CreateCommand(interp, "set_dcache_ports",
set_dcache_ports, legupConfig, 0);
Tcl_CreateCommand(interp, "set_dcache_type",
set_dcache_type, legupConfig, 0);
Tcl_CreateCommand(interp, "set_operation_attributes",
set_operation_attributes, legupConfig, 0);
Tcl_CreateCommand(interp, "set_device_specs",
set_device_specs, legupConfig, 0);
Tcl_CreateCommand(interp, "set_parameter",
set_parameter, legupConfig, 0);
Tcl_CreateCommand(interp, "loop_pipeline",
loop_pipeline, legupConfig, 0);
Tcl_CreateCommand(interp, "get_device_family",
get_device_family, legupConfig, 0);
int result = Tcl_EvalFile(interp, ConfigFile.c_str());
if (result != TCL_OK) {
errs() << ConfigFile << ":" << interp->errorLine << ": error: " <<
Tcl_GetStringResult(interp) << "\n";
}
Tcl_DeleteInterp(interp);
// can't call Tcl_Finalize() here - if we have multiple files then we'll
// get a segfault. But note that without this call Tcl leaks some memory
//Tcl_Finalize();
return (result == TCL_OK);
}
int appinit(Tcl_Interp *interp)
{
if (Tcl_Init(interp) == TCL_ERROR)
return TCL_ERROR;
#ifdef TK
if (Tk_Init(interp) == TCL_ERROR)
return TCL_ERROR;
#endif
/*
installation of tcl commands
*/
register_tcl_commands(interp);
register_global_variables(interp);
/* evaluate the Tcl initialization script */
char *scriptdir = getenv("ESPRESSO_SCRIPTS");
if (!scriptdir)
scriptdir = get_default_scriptsdir();
/* fprintf(stderr,"Script directory: %s\n", scriptdir);*/
char cwd[1024];
if ((getcwd(cwd, 1024) == NULL) || (chdir(scriptdir) != 0)) {
fprintf(stderr,
"\n\ncould not change to script dir %s, please check ESPRESSO_SCRIPTS.\n\n\n",
scriptdir);
exit(1);
}
if (Tcl_EvalFile(interp, "init.tcl") == TCL_ERROR) {
fprintf(stderr, "\n\nerror in initialization script: %s\n\n\n",
Tcl_GetStringResult(interp));
exit(1);
}
if (chdir(cwd) != 0) {
fprintf(stderr,
"\n\ncould not change back to execution dir %s ????\n\n\n",
cwd);
exit(1);
}
return (TCL_OK);
}
/********************************************************************************************
* test_Source
* purpose : This function replaces the "source" command of the TCL
* input : clientData - used for creating new command in tcl
* interp - interpreter for tcl commands
* argc - number of parameters entered to the new command
* argv - the parameters entered to the tcl command
* output : none
* return : TCL_OK
********************************************************************************************/
int test_Source(ClientData clientData, Tcl_Interp *interp,int argc, char *argv[])
{
FILE* exists;
char* fileBuf;
if (argc != 2)
{
Tcl_SetResult(interp, (char *)"wrong # args: should be \"source <filename>\"", TCL_STATIC);
return TCL_ERROR;
}
/* First see if we've got such a file on the disk */
exists = fopen(argv[1], "r");
if (exists == NULL)
{
/* File doesn't exist - get from compiled array */
fileBuf = tclGetFile(argv[1]);
if (fileBuf == NULL)
{
/* No such luck - we don't have a file to show */
char error[300];
sprintf(error, "file %s not found", argv[1]);
Tcl_SetResult(interp, error, TCL_VOLATILE);
return TCL_ERROR;
}
else
{
/* Found! */
int retCode;
retCode = Tcl_Eval(interp, fileBuf);
if (retCode == TCL_ERROR)
{
char error[300];
sprintf(error, "\n (file \"%s\" line %d)", argv[1], interp->errorLine);
Tcl_AddErrorInfo(interp, error);
}
return retCode;
}
}
/* File exists - evaluate from the file itself */
return Tcl_EvalFile(interp, argv[1]);
}
void tcltk_set_graph_mode (int mode, void (*drawimage)()) {
if (Tcl_EvalFile (interp,"rbd.tcl")==TCL_ERROR) {
printf ("rbd.tcl script error <%s>\n",interp->result);
exit (1);
}
canvas=Tk_NameToWindow (interp,".c",window);
if (canvas==NULL) {
printf ("Error: <%s>\n",interp->result);
}
gen_image=drawimage;
Tcl_CreateCommand
(interp,"drawimage",draw_image,(ClientData)window,NULL);
Tk_CreateEventHandler
(canvas,ExposureMask,(Tk_EventProc *)expose_handler,(ClientData)canvas);
Tk_MainLoop ();
}
int
TkWin_init(void)
{
interp = Tcl_CreateInterp();
if (Tcl_Init(interp) == TCL_ERROR) { return 0; }
if (Tk_Init(interp) == TCL_ERROR) { return 0; }
TkWin_createCommands();
TkSpooler_init(interp);
TkTape_init(interp);
if (Tcl_EvalFile(interp, "src/canace.tcl") == TCL_ERROR ) {
fprintf(stderr, "Error: Can't eval src/canace.tcl\n");
return 0;
}
TkWin_displayWindow();
return 1;
}
void Start() {
CString sMyArgs = GetArgs();
interp = Tcl_CreateInterp();
Tcl_Init(interp);
Tcl_CreateCommand(interp, "Binds::ProcessPubm", tcl_Bind, this, NULL);
Tcl_CreateCommand(interp, "Binds::ProcessTime", tcl_Bind, this, NULL);
Tcl_CreateCommand(interp, "Binds::ProcessEvnt", tcl_Bind, this, NULL);
Tcl_CreateCommand(interp, "Binds::ProcessNick", tcl_Bind, this, NULL);
Tcl_CreateCommand(interp, "Binds::ProcessKick", tcl_Bind, this, NULL);
Tcl_CreateCommand(interp, "PutIRC", tcl_PutIRC, this, NULL);
Tcl_CreateCommand(interp, "PutIRCAs", tcl_PutIRCAs, this, NULL);
Tcl_CreateCommand(interp, "PutModule", tcl_PutModule, this, NULL);
Tcl_CreateCommand(interp, "PutStatus", tcl_PutStatus, this, NULL);
Tcl_CreateCommand(interp, "PutStatusNotice", tcl_PutStatusNotice, this, NULL);
Tcl_CreateCommand(interp, "PutUser", tcl_PutUser, this, NULL);
Tcl_CreateCommand(interp, "GetLocalIP", tcl_GetLocalIP, this, NULL);
Tcl_CreateCommand(interp, "GetCurNick", tcl_GetCurNick, this, NULL);
Tcl_CreateCommand(interp, "GetUsername", tcl_GetUsername, this, NULL);
Tcl_CreateCommand(interp, "GetRealName", tcl_GetRealName, this, NULL);
Tcl_CreateCommand(interp, "GetVHost", tcl_GetBindHost, this, NULL);
Tcl_CreateCommand(interp, "GetBindHost", tcl_GetBindHost, this, NULL);
Tcl_CreateCommand(interp, "GetChans", tcl_GetChans, this, NULL);
Tcl_CreateCommand(interp, "GetChannelUsers", tcl_GetChannelUsers, this, NULL);
Tcl_CreateCommand(interp, "GetChannelModes", tcl_GetChannelModes, this, NULL);
Tcl_CreateCommand(interp, "GetServer", tcl_GetServer, this, NULL);
Tcl_CreateCommand(interp, "GetServerOnline", tcl_GetServerOnline, this, NULL);
Tcl_CreateCommand(interp, "GetModules", tcl_GetModules, this, NULL);
Tcl_CreateCommand(interp, "exit", tcl_exit, this, NULL);
if (!sMyArgs.empty()) {
i = Tcl_EvalFile(interp, sMyArgs.c_str());
if (i != TCL_OK) {
PutModule(Tcl_GetStringResult(interp));
}
}
AddTimer(new CModTclTimer(this, 1, 0, "ModTclUpdate", "Timer for modtcl to process pending events and idle callbacks."));
}
void
Tcl_SourceRCFile(
Tcl_Interp *interp) /* Interpreter to source rc file into. */
{
Tcl_DString temp;
const char *fileName;
Tcl_Channel chan;
fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
if (fileName != NULL) {
Tcl_Channel c;
const char *fullName;
Tcl_DStringInit(&temp);
fullName = Tcl_TranslateFileName(interp, fileName, &temp);
if (fullName == NULL) {
/*
* Couldn't translate the file name (e.g. it referred to a bogus
* user or there was no HOME environment variable). Just do
* nothing.
*/
} else {
/*
* Test for the existence of the rc file before trying to read it.
*/
c = Tcl_OpenFileChannel(NULL, fullName, "r", 0);
if (c != NULL) {
Tcl_Close(NULL, c);
if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
}
}
}
Tcl_DStringFree(&temp);
}
}
int ObjectiveFunction::update(){
/* check and
1. run userinput tcl file
2, to get value Vector
4, to get Graident Vector (if isGradientPrivided)
*/
if(Tcl_EvalFile(theTclInterp, TclFileName) !=TCL_OK){
opserr<<"the file "<<TclFileName<<" can not be run!"<<endln;
exit(-1);
}
/* if (Tcl_GetDouble(theTclInterp, name, &value) != TCL_OK) {
opserr << "ERROR: invalid input: value \n";
return TCL_ERROR;
}
*/
const char * myStr;
myStr = Tcl_GetVar(theTclInterp, name,TCL_GLOBAL_ONLY );
value = atof(myStr);
// opserr<<"ObjectiveFunction::update theValue is"<<value<<endln;
if(isGradientProvided()){
int numOfDvs = theOptimizationDomain->getNumberOfDesignVariables();
char index[5];
const char * myValue;
for(int i=0; i<numOfDvs;i++){
sprintf(index,"%d",i+1); // index from 1
myValue = Tcl_GetVar2(theTclInterp, gradientName,index,TCL_GLOBAL_ONLY);
(*gradient)(i) = atof(myValue);
}//for
}//if
numOfComputation++;
return 0;
};
static PyObject *
Tkapp_EvalFile(PyObject *self, PyObject *args)
{
char *fileName;
PyObject *res = NULL;
int err;
if (!PyArg_ParseTuple(args, "s:evalfile", &fileName))
return NULL;
ENTER_TCL
err = Tcl_EvalFile(Tkapp_Interp(self), fileName);
ENTER_OVERLAP
if (err == TCL_ERROR)
res = Tkinter_Error(self);
else
res = PyString_FromString(Tkapp_Result(self));
LEAVE_OVERLAP_TCL
return res;
}
int Tcl_AppInit(Tcl_Interp *interp){
// Tcl_Init(interp);
// Tcl_SourceRCFile(interp);
//Tcl_SetStartupScript("/remote/us01home19/szhang/scratch/disk.dc/dc2nwtn/misc/tcltrace.tcl",NULL);
// parse_tcl_command(interp);
// Tcl_AllowExceptions(interp);
Parsetcl_Init(interp);
Tcl_StaticPackage(interp, "Parsetcl", Parsetcl_Init, NULL);
/*
if(TCL_OK != Tcl_Eval(interp,"load {} Parsetcl")){
printf("Error: load error\n");
}
*/
char buf[512];
const char *name = Tcl_GetNameOfExecutable();
sprintf(buf, "%s.lib.tcl", name);
Tcl_EvalFile(interp, buf);
//Tcl_Obj *startup = Tcl_GetStartupScript(NULL);
//parse_tcl_file(interp,"dcp558_gif_fp.cstr.tcl");
/*
int level = 0;
int flags = 0; // TCL_ALLOW_INLINE_COMPILATION
Tcl_CmdObjTraceProc *objProc = Tcl_CmdObjTraceProc_impl;
ClientData clientData = 0;
Tcl_CmdObjTraceDeleteProc *deleteProc=NULL;
Tcl_CreateObjTrace(interp, level, flags, objProc, clientData, deleteProc);
*/
// Tcl_Eval(interp,"exit");
return TCL_OK;
}
void init_tpm(void)
{
char initfile[PATH_MAX];
int val;
PlutoInterp = Tcl_CreateInterp();
State_SafeInit(PlutoInterp);
tpm_initCallbacks(PlutoInterp);
snprintf(initfile, sizeof(initfile), "%s/tpm.tcl", ipsec_dir);
if(access(initfile, R_OK)!=0) {
if(errno == ENOENT) {
libreswan_log("No file '%s' found, TPM disabled\n", initfile);
} else {
libreswan_log("TPM disabled: cannot open TPM file '%s':%s\n"
, initfile
, strerror(errno));
}
return;
}
libreswan_log("Loading TPM file: '%s'\n", initfile);
val = Tcl_EvalFile(PlutoInterp, initfile);
switch(val) {
case TCL_OK:
libreswan_log("TPM enabled\n");
tpm_enabled = TRUE;
return;
case TCL_ERROR:
case TCL_RETURN:
case TCL_BREAK:
case TCL_CONTINUE:
libreswan_log("TPM load error: %s\n", Tcl_GetObjResult(PlutoInterp));
break;
}
return;
}
int proxenet_tcl_load_file(plugin_t* plugin)
{
char* pathname;
Tcl_Interp* tcl_interpreter;
Tcl_Obj* tcl_cmds_ptr;
if(plugin->state != INACTIVE){
#ifdef DEBUG
if(cfg->verbose > 2)
xlog_tcl(LOG_DEBUG, "Plugin '%s' is already loaded. Skipping...\n", plugin->name);
#endif
return 0;
}
pathname = plugin->fullpath;
tcl_interpreter = (Tcl_Interp*) plugin->interpreter->vm;
if (Tcl_EvalFile (tcl_interpreter, pathname) != TCL_OK){
xlog_tcl(LOG_ERROR, "Failed to load '%s'\n", pathname);
return -1;
}
plugin->interpreter->vm = tcl_interpreter;
plugin->interpreter->ready = true;
tcl_cmds_ptr = Tcl_NewListObj (0, NULL);
Tcl_IncrRefCount(tcl_cmds_ptr);
Tcl_ListObjAppendElement(tcl_interpreter, tcl_cmds_ptr, Tcl_NewStringObj(CFG_ONLEAVE_PLUGIN_FUNCTION, -1));
if (Tcl_EvalObjEx(tcl_interpreter, tcl_cmds_ptr, TCL_EVAL_DIRECT) != TCL_OK) {
xlog_tcl(LOG_WARNING, "%s() failed to execute properly\n", CFG_ONLOAD_PLUGIN_FUNCTION);
}
Tcl_DecrRefCount(tcl_cmds_ptr);
return 0;
}
/*
** If the macro TCLSH is defined and is one, then put in code for the
** "main" routine that will initialize Tcl.
*/
#if defined(TCLSH) && TCLSH==1
static char zMainloop[] =
"set line {}\n"
"while {![eof stdin]} {\n"
"if {$line!=\"\"} {\n"
"puts -nonewline \"> \"\n"
"} else {\n"
"puts -nonewline \"% \"\n"
"}\n"
"flush stdout\n"
"append line [gets stdin]\n"
"if {[info complete $line]} {\n"
"if {[catch {uplevel #0 $line} result]} {\n"
"puts stderr \"Error: $result\"\n"
"} elseif {$result!=\"\"} {\n"
"puts $result\n"
"}\n"
"set line {}\n"
"} else {\n"
"append line \\n\n"
"}\n"
"}\n"
;
#define TCLSH_MAIN main /* Needed to fake out mktclapp */
int TCLSH_MAIN(int argc, char **argv){
Tcl_Interp *interp;
Tcl_FindExecutable(argv[0]);
interp = Tcl_CreateInterp();
Sqlite_Init(interp);
#ifdef SQLITE_TEST
{
extern int Sqlitetest1_Init(Tcl_Interp*);
extern int Sqlitetest2_Init(Tcl_Interp*);
extern int Sqlitetest3_Init(Tcl_Interp*);
extern int Sqlitetest4_Init(Tcl_Interp*);
extern int Md5_Init(Tcl_Interp*);
Sqlitetest1_Init(interp);
Sqlitetest2_Init(interp);
Sqlitetest3_Init(interp);
Sqlitetest4_Init(interp);
Md5_Init(interp);
}
#endif
if( argc>=2 ){
int i;
Tcl_SetVar(interp,"argv0",argv[1],TCL_GLOBAL_ONLY);
Tcl_SetVar(interp,"argv", "", TCL_GLOBAL_ONLY);
for(i=2; i<argc; i++){
Tcl_SetVar(interp, "argv", argv[i],
TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT | TCL_APPEND_VALUE);
}
if( Tcl_EvalFile(interp, argv[1])!=TCL_OK ){
const char *zInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
if( zInfo==0 ) zInfo = interp->result;
fprintf(stderr,"%s: %s\n", *argv, zInfo);
return 1;
}
}else{
Tcl_GlobalEval(interp, zMainloop);
}
return 0;
}
int proxenet_tcl_load_file(plugin_t* plugin)
{
char* pathname;
Tcl_Interp* tcl_interpreter;
if(plugin->state != INACTIVE){
#ifdef DEBUG
if(cfg->verbose > 2)
xlog_tcl(LOG_DEBUG, "Plugin '%s' is already loaded. Skipping...\n", plugin->name);
#endif
return 0;
}
pathname = plugin->fullpath;
tcl_interpreter = (Tcl_Interp*) plugin->interpreter->vm;
if (Tcl_EvalFile (tcl_interpreter, pathname) != TCL_OK){
xlog_tcl(LOG_ERROR, "Failed to load '%s'\n", pathname);
return -1;
}
return 0;
}
void tclpd_setup(void) {
if(tclpd_interp) {
return;
}
/* verbose(-1) post to the pd window at level 3 */
verbose(-1, "tclpd loader v" TCLPD_VERSION);
proxyinlet_setup();
tclpd_interp = Tcl_CreateInterp();
Tcl_Init(tclpd_interp);
Tclpd_SafeInit(tclpd_interp);
Tcl_Eval(tclpd_interp, "package provide Tclpd " TCLPD_VERSION);
t_class *foo_class = class_new(gensym("tclpd_init"), 0, 0, 0, 0, 0);
char buf[PATH_MAX];
snprintf(buf, PATH_MAX, "%s/tclpd.tcl", foo_class->c_externdir->s_name);
verbose(-1, "tclpd: trying to load %s...", buf);
int result = Tcl_EvalFile(tclpd_interp, buf);
switch(result) {
case TCL_ERROR:
error("tclpd: error loading %s", buf);
break;
case TCL_RETURN:
error("tclpd: warning: %s exited with code return", buf);
break;
case TCL_BREAK:
case TCL_CONTINUE:
error("tclpd: warning: %s exited with code break/continue", buf);
break;
}
verbose(-1, "tclpd: loaded %s", buf);
sys_register_loader(tclpd_do_load_lib);
}
int main (int argc, char *argv[])
{
/* some variables */
char *mycvar, *params;
const char *mytclvar;
int x;
/* initialize Tcl Interpreter */
Tcl_Interp *interp;
interp = Tcl_CreateInterp ();
Tcl_Init (interp);
/* Set example variable and insert command */
mycvar = "this is my cvar";
Tcl_CreateCommand (interp, "mycout", tcl_mycout, 0, 0);
Tcl_SetVar (interp, "mycvar", mycvar, TCL_GLOBAL_ONLY);
/* exec example.tcl */
printf("Evaluating: example.tcl\n");
Tcl_EvalFile (interp, "./example.tcl");
/* you should see output from mycout now */
/* now read mytclvar from the script */
mytclvar = Tcl_GetVar (interp, "mytclvar", TCL_GLOBAL_ONLY);
printf("mytclvar = %s\n", mytclvar);
/* now try to execute mytclproc */
params = " see me";
x = Tcl_VarEval (interp, "mytclproc", params, 0);
if (x == TCL_ERROR)
printf("Tcl Error: %s\n", interp->result);
else
printf("Tcl Said: %s\n", interp->result);
return 0;
}
static int
SourceInitFiles(Tcl_Interp *interp)
{
char *fileName;
const char *library;
Tcl_DString dst;
library = Tcl_GetVar2(interp, "tnm", "library", TCL_GLOBAL_ONLY);
if (! library) {
Tcl_Panic("Tnm Tcl variable tnm(library) undefined.");
}
Tcl_DStringInit(&dst);
Tcl_DStringAppend(&dst, library, -1);
Tcl_DStringAppend(&dst, "/library/init.tcl", -1);
if (Tcl_EvalFile(interp, Tcl_DStringValue(&dst)) != TCL_OK) {
Tcl_DStringFree(&dst);
return TCL_ERROR;
}
Tcl_DStringFree(&dst);
/*
* Load the user specific startup file. Check whether we
* have a readable startup file so that we only complain
* about errors when we are expected to complain.
*/
fileName = getenv("TNM_RCFILE");
if (fileName) {
SourceRcFile(interp, fileName);
} else {
if (! SourceRcFile(interp, "~/.tnmrc")) {
SourceRcFile(interp, "~/.scottyrc");
}
}
return TCL_OK;
}
int Tcl_AppInit(Tcl_Interp *interp)
{
if(Tcl_Init(interp) == TCL_ERROR)
return TCL_ERROR;
if(Tk_Init(interp) == TCL_ERROR)
return TCL_ERROR;
if(TB_Init(interp) == TCL_ERROR)
return TCL_ERROR;
#ifdef USE_TIDE
if(Tide_Init(interp) == TCL_ERROR)
return TCL_ERROR;
#endif
if(script) {
if(Tcl_EvalFile(interp, script) != TCL_OK) {
handle_error(interp, interp->result);
}
}
return TCL_OK;
}
/* Initialisation, based on tkMain.c */
value camltk_opentk(value argv) /* ML */
{
/* argv must contain argv[0], the application command name */
value tmp = Val_unit;
char *argv0;
Begin_root(tmp);
if ( argv == Val_int(0) ){
failwith("camltk_opentk: argv is empty");
}
argv0 = String_val( Field( argv, 0 ) );
if (!cltk_slave_mode) {
/* Create an interpreter, dies if error */
#if TCL_MAJOR_VERSION >= 8
Tcl_FindExecutable(String_val(argv0));
#endif
cltclinterp = Tcl_CreateInterp();
if (Tcl_Init(cltclinterp) != TCL_OK)
tk_error(cltclinterp->result);
Tcl_SetVar(cltclinterp, "argv0", String_val (argv0), TCL_GLOBAL_ONLY);
{ /* Sets argv if needed */
int argc = 0;
tmp = Field(argv, 1); /* starts from argv[1] */
while ( tmp != Val_int(0) ) {
argc++;
tmp = Field(tmp, 1);
}
if( argc != 0 ){
int i;
char *args;
char **tkargv;
char argcstr[256];
tkargv = malloc( sizeof( char* ) * argc );
tmp = Field(argv, 1); /* starts from argv[1] */
i = 0;
while ( tmp != Val_int(0) ) {
tkargv[i] = String_val(Field(tmp, 0));
tmp = Field(tmp, 1);
i++;
}
sprintf( argcstr, "%d", argc );
Tcl_SetVar(cltclinterp, "argc", argcstr, TCL_GLOBAL_ONLY);
args = Tcl_Merge(argc, tkargv); /* args must be freed by Tcl_Free */
Tcl_SetVar(cltclinterp, "argv", args, TCL_GLOBAL_ONLY);
Tcl_Free(args);
free( tkargv );
}
}
if (Tk_Init(cltclinterp) != TCL_OK)
tk_error(cltclinterp->result);
/* Retrieve the main window */
cltk_mainWindow = Tk_MainWindow(cltclinterp);
if (NULL == cltk_mainWindow)
tk_error(cltclinterp->result);
Tk_GeometryRequest(cltk_mainWindow,200,200);
}
/* Create the camlcallback command */
Tcl_CreateCommand(cltclinterp,
CAMLCB, CamlCBCmd,
(ClientData)NULL,(Tcl_CmdDeleteProc *)NULL);
/* This is required by "unknown" and thus autoload */
Tcl_SetVar(cltclinterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY);
/* Our hack for implementing break in callbacks */
Tcl_SetVar(cltclinterp, "BreakBindingsSequence", "0", TCL_GLOBAL_ONLY);
/* Load the traditional rc file */
{
char *home = getenv("HOME");
if (home != NULL) {
char *f = stat_alloc(strlen(home)+strlen(RCNAME)+2);
f[0]='\0';
strcat(f, home);
strcat(f, "/");
strcat(f, RCNAME);
if (0 == access(f,R_OK))
if (TCL_OK != Tcl_EvalFile(cltclinterp,f)) {
stat_free(f);
tk_error(cltclinterp->result);
};
stat_free(f);
}
}
End_roots();
return Val_unit;
}
void tcltk_init(int *TkUp)
{
int code;
*TkUp = 0;
/* Absence of the following line is said to be an error with
* tcl >= 8.4 on all platforms, and is known to cause crashes under
* Windows */
Tcl_FindExecutable(NULL);
RTcl_interp = Tcl_CreateInterp();
code = Tcl_Init(RTcl_interp);
if (code != TCL_OK) error(Tcl_GetStringResult(RTcl_interp));
/* HAVE_AQUA is not really right here.
On Mac OS X we might be using Aqua Tcl/Tk or X11 Tcl/Tk, and that
is in principle independent of whether we want quartz() built.
*/
#if !defined(Win32) && !defined(HAVE_AQUA)
char *p= getenv("DISPLAY");
if(p && p[0]) /* exclude DISPLAY = "" */
#endif
{
code = Tk_Init(RTcl_interp); /* Load Tk into interpreter */
if (code != TCL_OK) {
warning(Tcl_GetStringResult(RTcl_interp));
} else {
Tcl_StaticPackage(RTcl_interp, "Tk", Tk_Init, Tk_SafeInit);
code = Tcl_Eval(RTcl_interp, "wm withdraw ."); /* Hide window */
if (code != TCL_OK) error(Tcl_GetStringResult(RTcl_interp));
*TkUp = 1;
}
}
#if !defined(Win32) && !defined(HAVE_AQUA)
else
warningcall(R_NilValue, _("no DISPLAY variable so Tk is not available"));
#endif
Tcl_CreateCommand(RTcl_interp,
"R_eval",
R_eval,
(ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(RTcl_interp,
"R_call",
R_call,
(ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(RTcl_interp,
"R_call_lang",
R_call_lang,
(ClientData) NULL,
(Tcl_CmdDeleteProc *) NULL);
#ifndef Win32
Tcl_unix_setup();
#endif
Tcl_SetServiceMode(TCL_SERVICE_ALL);
/*** We may want to revive this at some point ***/
#if 0
code = Tcl_EvalFile(RTcl_interp, "init.tcl");
if (code != TCL_OK)
error("%s\n", Tcl_GetStringResult(RTcl_interp));
#endif
}
static OSErr
ScriptHandler(
const AppleEvent *event,
AppleEvent *reply,
long handlerRefcon)
{
OSStatus theErr;
AEDescList theDesc;
Size size;
int tclErr = -1;
Tcl_Interp *interp = (Tcl_Interp *) handlerRefcon;
char errString[128];
/*
* The do script event receives one parameter that should be data or a
* file.
*/
theErr = AEGetParamDesc(event, keyDirectObject, typeWildCard,
&theDesc);
if (theErr != noErr) {
sprintf(errString, "AEDoScriptHandler: GetParamDesc error %d",
(int)theErr);
theErr = AEPutParamPtr(reply, keyErrorString, typeChar, errString,
strlen(errString));
} else if (MissedAnyParameters(event)) {
/*
* Return error if parameter is missing.
*/
sprintf(errString, "AEDoScriptHandler: extra parameters");
AEPutParamPtr(reply, keyErrorString, typeChar, errString,
strlen(errString));
theErr = -1771;
} else if (theDesc.descriptorType == (DescType) typeAlias &&
AEGetParamPtr(event, keyDirectObject, typeFSRef, NULL, NULL,
0, &size) == noErr && size == sizeof(FSRef)) {
/*
* We've had a file sent to us. Source it.
*/
FSRef file;
theErr = AEGetParamPtr(event, keyDirectObject, typeFSRef, NULL, &file,
size, NULL);
if (theErr == noErr) {
Tcl_DString scriptName;
theErr = FSRefToDString(&file, &scriptName);
if (theErr == noErr) {
tclErr = Tcl_EvalFile(interp, Tcl_DStringValue(&scriptName));
Tcl_DStringFree(&scriptName);
} else {
sprintf(errString, "AEDoScriptHandler: file not found");
AEPutParamPtr(reply, keyErrorString, typeChar, errString,
strlen(errString));
}
}
} else if (AEGetParamPtr(event, keyDirectObject, typeUTF8Text, NULL, NULL,
0, &size) == noErr && size) {
/*
* We've had some data sent to us. Evaluate it.
*/
char *data = ckalloc(size + 1);
theErr = AEGetParamPtr(event, keyDirectObject, typeUTF8Text, NULL, data,
size, NULL);
if (theErr == noErr) {
tclErr = Tcl_EvalEx(interp, data, size, TCL_EVAL_GLOBAL);
}
} else {
/*
* Umm, don't recognize what we've got...
*/
sprintf(errString, "AEDoScriptHandler: invalid script type '%-4.4s', "
"must be 'alis' or coercable to 'utf8'",
(char*) &theDesc.descriptorType);
AEPutParamPtr(reply, keyErrorString, typeChar, errString,
strlen(errString));
theErr = -1770;
}
/*
* If we actually go to run Tcl code - put the result in the reply.
*/
if (tclErr >= 0) {
int reslen;
const char *result =
Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &reslen);
if (tclErr == TCL_OK) {
AEPutParamPtr(reply, keyDirectObject, typeChar, result, reslen);
} else {
AEPutParamPtr(reply, keyErrorString, typeChar, result, reslen);
AEPutParamPtr(reply, keyErrorNumber, typeSInt32, (Ptr) &tclErr,
sizeof(int));
}
}
AEDisposeDesc(&theDesc);
return theErr;
}
int tcl::load(char *script)
{
int status = Tcl_EvalFile(tcl_int, script);
if(status == TCL_ERROR) return 0;
return 1;
}
int
TclInterpreter::run() {
/*
* If a script file was specified then just source that file
* and quit.
*/
if (tclStartupScriptFileName != NULL) {
code = Tcl_EvalFile(interp, tclStartupScriptFileName);
if (code != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
/*
* The following statement guarantees that the errorInfo
* variable is set properly.
*/
Tcl_AddErrorInfo(interp, "");
Tcl_WriteObj(errChannel, Tcl_GetVar2Ex(interp, "errorInfo",
NULL, TCL_GLOBAL_ONLY));
Tcl_WriteChars(errChannel, "\n", 1);
}
exitCode = 1;
}
return 0;
}
else {
/*
const char *pwd = getInterpPWD(interp);
simulationInfo.start();
simulationInfo.addInputFile(tclStartupScriptFileName, pwd);
*/
/*
* We're running interactively. Source a user-specific startup
* file if the application specified one and if the file exists.
*/
Tcl_DStringFree(&argString);
Tcl_SourceRCFile(interp);
/*
* Process commands from stdin until there's an end-of-file. Note
* that we need to fetch the standard channels again after every
* eval, since they may have been changed.
*/
/*
if (simulationInfoOutputFilename != 0) {
simulationInfo.start();
}
*/
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
gotPartial = 0;
while (1) {
if (tty) {
Tcl_Obj *promptCmdPtr;
char one[12] = "tcl_prompt1";
char two[12] = "tcl_prompt2";
promptCmdPtr = Tcl_GetVar2Ex(interp,
(gotPartial ? one : two),
NULL, TCL_GLOBAL_ONLY);
if (promptCmdPtr == NULL) {
defaultPrompt:
if (!gotPartial && outChannel) {
Tcl_WriteChars(outChannel, "OpenSees > ", 11);
}
} else {
code = Tcl_EvalObjEx(interp, promptCmdPtr, 0);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (code != TCL_OK) {
if (errChannel) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
Tcl_AddErrorInfo(interp,
"\n (script that generates prompt)");
goto defaultPrompt;
}
}
if (outChannel) {
Tcl_Flush(outChannel);
}
}
if (!inChannel) {
return 0;
// goto done;
}
length = Tcl_GetsObj(inChannel, commandPtr);
if (length < 0) {
return 0; //goto done;
}
if ((length == 0) && Tcl_Eof(inChannel) && (!gotPartial)) {
return 0; // goto done;
}
/*
* Add the newline removed by Tcl_GetsObj back to the string.
*/
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
gotPartial = 1;
continue;
}
gotPartial = 0;
code = Tcl_RecordAndEvalObj(interp, commandPtr, 0);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
if (code != TCL_OK) {
if (errChannel) {
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
} else if (tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && outChannel) {
Tcl_WriteObj(outChannel, resultPtr);
Tcl_WriteChars(outChannel, "\n", 1);
}
}
#ifdef TCL_MEM_DEBUG
if (tclMemDumpFileName != NULL) {
Tcl_DecrRefCount(commandPtr);
Tcl_DeleteInterp(interp);
Tcl_Exit(0);
}
#endif
}
}
return 0;
}
/*--------------------------------------------------------------------------*/
static void *DaemonOpenTCLsci(void* in)
/* Checks if tcl/tk has already been initialised and if not */
/* initialise it. It must find the tcl script */
{
char *SciPath = NULL;
char *SciPathShort = NULL;
char *TkScriptpathShort = NULL;
BOOL tkStarted = FALSE;
BOOL bOK = FALSE;
char TkScriptpath[PATH_MAX];
char MyCommand[2048]; /* @TODO: Check for buffer overflow */
#ifndef _MSC_VER
DIR *tmpdir = NULL;
#endif
FILE *tmpfile2 = NULL;
SciPath = GetSciPath();
/* test SCI validity */
if (SciPath == NULL)
{
sciprint(_("The SCI environment variable is not set.\nTCL initialisation failed !\n"));
}
SciPathShort = getshortpathname(SciPath, &bOK);
#ifdef TCL_MAJOR_VERSION
#ifdef TCL_MINOR_VERSION
#if TCL_MAJOR_VERSION >= 8
#if TCL_MINOR_VERSION > 0
Tcl_FindExecutable(" ");
#endif
#endif
#endif
#endif
#ifdef _MSC_VER
strcpy(TkScriptpath, SciPathShort);
strcat(TkScriptpath, "/modules/tclsci/tcl/TK_Scilab.tcl");
TkScriptpathShort = getshortpathname(TkScriptpath, &bOK);
tmpfile2 = fopen(TkScriptpathShort, "r");
if (tmpfile2 == NULL)
{
sciprint(_("Unable to find Tcl initialisation scripts.\nCheck your SCI environment variable.\nTcl initialisation failed !"));
}
else
{
fclose(tmpfile2);
}
#else
tmpdir = opendir(SciPathShort);
if (tmpdir == NULL)
{
sciprint(_("The SCI environment variable is not set.\nTcl initialisation failed !\n"));
}
else
{
closedir(tmpdir);
}
strcpy(TkScriptpath, SciPathShort);
strcat(TkScriptpath, "/modules/tclsci/tcl/TK_Scilab.tcl");
TkScriptpathShort = getshortpathname(TkScriptpath, &bOK);
tmpfile2 = fopen(TkScriptpathShort, "r");
if (tmpfile2 == NULL)
{
sciprint(_("Unable to find Tcl initialisation scripts.\nCheck your SCI environment variable.\nTcl initialisation failed !"));
}
else
{
fclose(tmpfile2);
}
#endif /* _MSC_VER */
if (getTclInterp() == NULL)
{
releaseTclInterp();
initTclInterp();
#ifdef _MSC_VER
/* Initialize TCL_LIBRARY & TK_LIBRARY variables environment */
/* Windows only */
SetTclTkEnvironment(SciPathShort);
#endif
if ( getTclInterp() == NULL )
{
Scierror(999, _("Tcl Error: Unable to create Tcl interpreter (Tcl_CreateInterp).\n"));
}
releaseTclInterp();
if ( Tcl_Init(getTclInterp()) == TCL_ERROR)
{
releaseTclInterp();
Scierror(999, _("Tcl Error: Error during the Tcl initialization (Tcl_Init): %s\n"), Tcl_GetStringResult(getTclInterp()));
}
releaseTclInterp();
if (getenv("SCI_DISABLE_TK") == NULL)
{
/* When SCI_DISABLE_TK is set in the env disable the TK init
* process. It is causing issues when Scilab is
* used through ssh. */
if ( Tk_Init(getTclInterp()) == TCL_ERROR)
{
releaseTclInterp();
Scierror(999, _("Tcl Error: Error during the TK initialization (Tk_Init): %s\n"), Tcl_GetStringResult(getTclInterp()));
}
else
{
tkStarted = TRUE;
}
releaseTclInterp();
}
sprintf(MyCommand, "set SciPath \"%s\";", SciPathShort);
if ( Tcl_Eval(getTclInterp(), MyCommand) == TCL_ERROR )
{
releaseTclInterp();
Scierror(999, _("Tcl Error: Error during the Scilab/Tcl init process. Could not set SciPath: %s\n"), Tcl_GetStringResult(getTclInterp()));
}
releaseTclInterp();
Tcl_CreateCommand(getTclInterp(), "ScilabEval", TCL_EvalScilabCmd, (ClientData)1, NULL);
releaseTclInterp();
}
if (TKmainWindow == NULL && tkStarted)
{
TKmainWindow = Tk_MainWindow(getTclInterp());
releaseTclInterp();
Tk_GeometryRequest(TKmainWindow, 2, 2);
//printf("TkScriptpathShort : |%s|\n", TkScriptpathShort);
if ( Tcl_EvalFile(getTclInterp(), TkScriptpathShort) == TCL_ERROR )
{
releaseTclInterp();
Scierror(999, _("Tcl Error: Error during the Scilab/TK init process. Error while loading %s: %s\n"), TkScriptpathShort, Tcl_GetStringResult(getTclInterp()));
}
releaseTclInterp();
}
if (SciPath)
{
FREE(SciPath);
SciPath = NULL;
}
if (SciPathShort)
{
FREE(SciPathShort);
SciPathShort = NULL;
}
if (TkScriptpathShort)
{
FREE(TkScriptpathShort);
TkScriptpathShort = NULL;
}
// This start a periodic and endless call to "update"
// TCL command. This causes any TCL application to start
// and run as if it's in the main program thread.
startTclLoop();
return(0);
}
