/* Sets up a Tcl interpreter for the game. Adds commands to implement our
scripting interface. */
void InitScripting(void)
{
/* First, create an interpreter and make sure it's valid. */
interp = Tcl_CreateInterp();
if (interp == NULL) {
fprintf(stderr, "Unable to initialize Tcl.\n");
exit(1);
}
/* Add the "fireWeapon" command. */
if (Tcl_CreateObjCommand(interp, "fireWeapon",
HandleFireWeaponCmd, (ClientData) 0,
NULL) == NULL) {
fprintf(stderr, "Error creating Tcl command.\n");
exit(1);
}
/* Link the important parts of our player data structures to global
variables in Tcl. (Ignore the char * typecast; Tcl will treat the data
as the requested type, in this case double.) */
Tcl_LinkVar(interp, "player_x", (char *) &player.world_x,
TCL_LINK_DOUBLE);
Tcl_LinkVar(interp, "player_y", (char *) &player.world_y,
TCL_LINK_DOUBLE);
Tcl_LinkVar(interp, "player_angle", (char *) &player.angle,
TCL_LINK_DOUBLE);
Tcl_LinkVar(interp, "player_accel", (char *) &player.accel,
TCL_LINK_DOUBLE);
Tcl_LinkVar(interp, "computer_x", (char *) &opponent.world_x,
TCL_LINK_DOUBLE);
Tcl_LinkVar(interp, "computer_y", (char *) &opponent.world_y,
TCL_LINK_DOUBLE);
Tcl_LinkVar(interp, "computer_angle", (char *) &opponent.angle,
TCL_LINK_DOUBLE);
Tcl_LinkVar(interp, "computer_accel", (char *) &opponent.accel,
TCL_LINK_DOUBLE);
/* Make the constants in gamedefs.h available to the script. The script
should play by the game's rules, just like the human player.
Tcl_SetVar2Ex is part of the Tcl_SetVar family of functions, which
you can read about in the manpage. It simply sets a variable to a new
value given by a Tcl_Obj structure. */
Tcl_SetVar2Ex(interp, "world_width", NULL, Tcl_NewIntObj(WORLD_WIDTH),
0);
Tcl_SetVar2Ex(interp, "world_height", NULL,
Tcl_NewIntObj(WORLD_HEIGHT), 0);
Tcl_SetVar2Ex(interp, "player_forward_thrust", NULL,
Tcl_NewIntObj(PLAYER_FORWARD_THRUST), 0);
Tcl_SetVar2Ex(interp, "player_reverse_thrust", NULL,
Tcl_NewIntObj(PLAYER_REVERSE_THRUST), 0);
}
static int
setArrayElement (Tcl_Interp *interp, const char *array, const char *element, Tcl_Obj *value) {
if (!value) return TCL_ERROR;
Tcl_IncrRefCount(value);
Tcl_Obj *result = Tcl_SetVar2Ex(interp, array, element, value, TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(value);
return result? TCL_OK: TCL_ERROR;
}
int
BasicGFunEvaluator::setTclRandomVariables(const Vector &x)
{
char theIndex[80];
double xval;
RandomVariable *theRV;
// Set values of random variables in the Tcl intepreter
int nrv = theReliabilityDomain->getNumberOfRandomVariables();
int lsf = theReliabilityDomain->getTagOfActiveLimitStateFunction();
for (int i = 0; i < nrv; i++) {
theRV = theReliabilityDomain->getRandomVariablePtrFromIndex(i);
int rvTag = theRV->getTag();
xval = x(i);
// put in x(1) format
sprintf(theIndex,"%d",rvTag);
if (Tcl_SetVar2Ex(theTclInterp,"xrv",theIndex,Tcl_NewDoubleObj(xval),TCL_LEAVE_ERR_MSG) == NULL) {
opserr << "ERROR GFunEvaluator -- error in setTclRandomVariables xrv" << endln;
opserr << theTclInterp->result << endln;
return -1;
}
// put in x(1,lsfTag) format (useful for reporting design point)
sprintf(theIndex,"%d,%d",rvTag,lsf);
if (Tcl_SetVar2Ex(theTclInterp,"xrv",theIndex,Tcl_NewDoubleObj(xval),TCL_LEAVE_ERR_MSG) == NULL) {
opserr << "ERROR GFunEvaluator -- error in setTclRandomVariables xrv" << endln;
opserr << theTclInterp->result << endln;
return -1;
}
// for legacy reasons, also put random variables in x_1 format
sprintf(theIndex,"x_%d",rvTag);
if (Tcl_SetVar2Ex(theTclInterp,theIndex,NULL,Tcl_NewDoubleObj(xval),TCL_LEAVE_ERR_MSG) == NULL) {
opserr << "ERROR GFunEvaluator -- error in setTclRandomVariables x" << endln;
opserr << theTclInterp->result << endln;
return -1;
}
}
return 0;
}
static int
asyncSignalHandler(ClientData data, Tcl_Interp *interp, int code)
{
ElTclSignalContext *ctx = data;
Tcl_Obj *result, *errorInfo, *errorCode;
if (ctx->script == ELTCL_SIGDFL || ctx->script == ELTCL_SIGIGN) {
fputs("Warning: wrong signal delivered for Tcl\n", stdout);
return code;
}
/* save interpreter state */
result = Tcl_GetObjResult(ctx->iinfo->interp);
if (result != NULL) Tcl_IncrRefCount(result);
errorInfo = Tcl_GetVar2Ex(ctx->iinfo->interp, "errorInfo", NULL,
TCL_GLOBAL_ONLY);
if (errorInfo != NULL) Tcl_IncrRefCount(errorInfo);
errorCode = Tcl_GetVar2Ex(ctx->iinfo->interp, "errorCode", NULL,
TCL_GLOBAL_ONLY);
if (errorCode != NULL) Tcl_IncrRefCount(errorCode);
/* eval script */
if (Tcl_EvalObjEx(ctx->iinfo->interp,
ctx->script, TCL_EVAL_GLOBAL) != TCL_OK)
Tcl_BackgroundError(ctx->iinfo->interp);
/* restore interpreter state */
if (errorInfo != NULL) {
Tcl_SetVar2Ex(ctx->iinfo->interp, "errorInfo", NULL, errorInfo,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(errorInfo);
}
if (errorCode != NULL) {
Tcl_SetVar2Ex(ctx->iinfo->interp, "errorCode", NULL, errorCode,
TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(errorCode);
}
if (result != NULL) {
Tcl_SetObjResult(ctx->iinfo->interp, result);
Tcl_DecrRefCount(result);
}
return code;
}
void InitScripting(void)
{
interp = Tcl_CreateInterp();
if ( interp == NULL ) {
fprintf( stderr, "Unable to initialize Tcl.\n" );
exit( 1 );
}
if ( Tcl_CreateObjCommand( interp, "fireWeapon",
HandleFireWeaponCmd, ( ClientData ) 0,
NULL ) == NULL) {
fprintf( stderr, "Error creating Tcl command.\n" );
exit(1);
}
Tcl_LinkVar( interp, "player_x", ( char * ) &player.world_x,
TCL_LINK_DOUBLE );
Tcl_LinkVar( interp, "player_y", ( char * ) &player.world_y,
TCL_LINK_DOUBLE );
Tcl_LinkVar( interp, "player_angle", ( char * ) &player.angle,
TCL_LINK_DOUBLE );
Tcl_LinkVar( interp, "player_accel", ( char * ) &player.accel,
TCL_LINK_DOUBLE );
Tcl_LinkVar( interp, "computer_x", ( char * ) &opponent.world_x,
TCL_LINK_DOUBLE );
Tcl_LinkVar( interp, "computer_y", ( char * ) &opponent.world_y,
TCL_LINK_DOUBLE );
Tcl_LinkVar( interp, "computer_angle", ( char * ) &opponent.angle,
TCL_LINK_DOUBLE );
Tcl_LinkVar( interp, "computer_accel", ( char * ) &opponent.accel,
TCL_LINK_DOUBLE );
Tcl_SetVar2Ex( interp, "world_width", NULL, Tcl_NewIntObj( WORLD_WIDTH ), 0);
Tcl_SetVar2Ex( interp, "world_height", NULL,
Tcl_NewIntObj( WORLD_HEIGHT ), 0);
Tcl_SetVar2Ex( interp, "player_forward_thrust", NULL,
Tcl_NewIntObj( PLAYER_FORWARD_THRUST ), 0);
Tcl_SetVar2Ex( interp, "player_reverse_thrust", NULL,
Tcl_NewIntObj( PLAYER_REVERSE_THRUST ), 0);
}
SEXP RTcl_AssignObjToVar(SEXP args)
{
const void *vmax = vmaxget();
Tcl_SetVar2Ex(RTcl_interp,
translateChar(STRING_ELT(CADR(args), 0)),
NULL,
(Tcl_Obj *) R_ExternalPtrAddr(CADDR(args)),
0);
vmaxset(vmax);
return R_NilValue;
}
static int setVariable( SpinButtonParams *para, Tcl_Obj *val )
{
if( para->variable && para->inSetVar == 0 )
{
Tcl_Obj *ret;
para->inSetVar = 1;
ret = Tcl_SetVar2Ex( para->interp, para->variable, NULL,
val, TCL_GLOBAL_ONLY );
para->inSetVar = 0;
return ret == NULL ? TCL_ERROR : TCL_OK;
}
return TCL_OK;
}
void RtclSignalAction::TclChannelHandler(int mask)
{
char signum;
Tcl_Read(fShuttleChn, (char*) &signum, sizeof(signum));
// FIXME_code: handle return code
Tcl_SetVar2Ex(fpInterp, "Rutil_signum", NULL, Tcl_NewIntObj((int)signum), 0);
// FIXME_code: handle return code
if ((Tcl_Obj*)fpScript[(int)signum]) {
Tcl_EvalObjEx(fpInterp, fpScript[(int)signum], TCL_EVAL_GLOBAL);
// FIXME_code: handle return code
}
return;
}
SEXP RTcl_SetArrayElem(SEXP args)
{
SEXP x, i;
const char *xstr, *istr;
Tcl_Obj *value;
const void *vmax = vmaxget();
x = CADR(args);
i = CADDR(args);
value = (Tcl_Obj *) R_ExternalPtrAddr(CADDDR(args));
xstr = translateChar(STRING_ELT(x, 0));
istr = translateChar(STRING_ELT(i, 0));
Tcl_SetVar2Ex(RTcl_interp, xstr, istr, value, 0);
vmaxset(vmax);
return R_NilValue;
}
int Gmlayer_Init(Tcl_Interp* interp)
{
static int initialized = 0;
Tcl_Obj *version;
int r;
#if 0
out = Tcl_GetChannel(interp, "stdout", NULL);
if (out == NULL) {
Tcl_AppendResult(interp, "could not find stdout", NULL);
return TCL_ERROR;
}
#endif
fit_interp = interp;
debug_message("gmlayer init\n");
if (initialized) {
Tcl_AppendResult(interp, "Only one copy of gmlayer is allowed", NULL);
return TCL_ERROR;
}
#ifdef USE_TCL_STUBS
Tcl_InitStubs(interp, "8.0", 0);
#endif
version = Tcl_SetVar2Ex(interp, "gmlayer_version", NULL,
Tcl_NewDoubleObj(0.1), TCL_LEAVE_ERR_MSG);
if (version == NULL)
return TCL_ERROR;
r = Tcl_PkgProvide(interp, "gmlayer", Tcl_GetString(version));
/* Global variable initialization */
strcpy(parfile, "mlayer.staj");
Constrain = noconstraints;
Tcl_CreateCommand(interp, "gmlayer",
gmlayer_TclCmd,
(ClientData)NULL,
gmlayer_TclEnd);
return r;
}
int
BasicGFunEvaluator::nodeTclVariable(int nodeNumber, int direction, char* dispOrWhat, char* varName, char* arrName)
{
// now obtain the information directly from domain without creating recorder files
Node *theNode = theOpenSeesDomain->getNode(nodeNumber);
if (theNode == 0) {
opserr << "GFunEvaluator::nodeTclVariable -- node with tag " << nodeNumber
<< " not found in OpenSees Domain" << endln;
return 0;
}
double gFunValue = 0.0;
if ( strncmp(dispOrWhat, "disp", 4) == 0) {
const Vector &theDisp = theNode->getDisp();
gFunValue = theDisp(direction-1);
}
else if ( strncmp(dispOrWhat, "vel", 3) == 0) {
const Vector &theDisp = theNode->getVel();
gFunValue = theDisp(direction-1);
}
else if ( strncmp(dispOrWhat, "accel", 5) == 0) {
const Vector &theDisp = theNode->getAccel();
gFunValue = theDisp(direction-1);
}
else {
opserr << "ERROR GFunEvaluator::nodeTclVariable in syntax (" << dispOrWhat << ") of limit-state function "
<< "with node recorder." << endln;
}
// set Tcl value
if (Tcl_SetVar2Ex(theTclInterp,varName,arrName,Tcl_NewDoubleObj(gFunValue),TCL_LEAVE_ERR_MSG) == NULL) {
opserr << "ERROR GFunEvaluator::nodeTclVariable -- SetVar error" << endln;
opserr << theTclInterp->result << endln;
return -1;
}
return 0;
}
void
Tcl_Main(
int argc, /* Number of arguments. */
char **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc)
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
{
Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL;
const char *encodingName = NULL;
PromptType prompt = PROMPT_START;
int code, length, tty, exitCode = 0;
Tcl_Channel inChannel, outChannel, errChannel;
Tcl_Interp *interp;
Tcl_DString appName;
Tcl_FindExecutable(argv[0]);
interp = Tcl_CreateInterp();
Tcl_InitMemory(interp);
/*
* If the application has not already set a startup script, parse the
* first few command line arguments to determine the script path and
* encoding.
*/
if (NULL == Tcl_GetStartupScript(NULL)) {
/*
* Check whether first 3 args (argv[1] - argv[3]) look like
* -encoding ENCODING FILENAME
* or like
* FILENAME
*/
if ((argc > 3) && (0 == strcmp("-encoding", argv[1]))
&& ('-' != argv[3][0])) {
Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]);
argc -= 3;
argv += 3;
} else if ((argc > 1) && ('-' != argv[1][0])) {
Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL);
argc--;
argv++;
}
}
path = Tcl_GetStartupScript(&encodingName);
if (path == NULL) {
Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName);
} else {
const char *pathName = Tcl_GetStringFromObj(path, &length);
Tcl_ExternalToUtfDString(NULL, pathName, length, &appName);
path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1);
Tcl_SetStartupScript(path, encodingName);
}
Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY);
Tcl_DStringFree(&appName);
argc--;
argv++;
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_DString ds;
Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds);
Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj(
Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
Tcl_DStringFree(&ds);
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
*/
tty = isatty(0);
Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0",
TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
Tcl_Preserve(interp);
if (appInitProc(interp) != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
Tcl_WriteChars(errChannel,
"application-specific initialization failed: ", -1);
Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
Tcl_WriteChars(errChannel, "\n", 1);
}
}
if (Tcl_InterpDeleted(interp)) {
goto done;
}
if (Tcl_LimitExceeded(interp)) {
goto done;
}
/*
* If a script file was specified then just source that file and quit.
* Must fetch it again, as the appInitProc might have reset it.
*/
path = Tcl_GetStartupScript(&encodingName);
if (path != NULL) {
code = Tcl_FSEvalFileEx(interp, path, encodingName);
if (code != TCL_OK) {
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errChannel) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr, *valuePtr;
TclNewLiteralStringObj(keyPtr, "-errorinfo");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
Tcl_WriteObj(errChannel, valuePtr);
}
Tcl_WriteChars(errChannel, "\n", 1);
}
exitCode = 1;
}
goto done;
}
/*
* We're running interactively. Source a user-specific startup file if the
* application specified one and if the file exists.
*/
Tcl_SourceRCFile(interp);
if (Tcl_LimitExceeded(interp)) {
goto done;
}
/*
* 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.
*/
commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(commandPtr);
/*
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
while ((inChannel != NULL) && !Tcl_InterpDeleted(interp)) {
if (mainLoopProc == NULL) {
if (tty) {
Prompt(interp, &prompt);
if (Tcl_InterpDeleted(interp)) {
break;
}
if (Tcl_LimitExceeded(interp)) {
break;
}
inChannel = Tcl_GetStdChannel(TCL_STDIN);
if (inChannel == NULL) {
break;
}
}
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
length = Tcl_GetsObj(inChannel, commandPtr);
if (length < 0) {
if (Tcl_InputBlocked(inChannel)) {
/*
* This can only happen if stdin has been set to
* non-blocking. In that case cycle back and try again.
* This sets up a tight polling loop (since we have no
* event loop running). If this causes bad CPU hogging, we
* might try toggling the blocking on stdin instead.
*/
continue;
}
/*
* Either EOF, or an error on stdin; we're done
*/
break;
}
/*
* Add the newline removed by Tcl_GetsObj back to the string. Have
* to add it back before testing completeness, because it can make
* a difference. [Bug 1775878]
*/
if (Tcl_IsShared(commandPtr)) {
Tcl_DecrRefCount(commandPtr);
commandPtr = Tcl_DuplicateObj(commandPtr);
Tcl_IncrRefCount(commandPtr);
}
Tcl_AppendToObj(commandPtr, "\n", 1);
if (!TclObjCommandComplete(commandPtr)) {
prompt = PROMPT_CONTINUE;
continue;
}
prompt = PROMPT_START;
/*
* The final newline is syntactically redundant, and causes some
* error messages troubles deeper in, so lop it back off.
*/
Tcl_GetStringFromObj(commandPtr, &length);
Tcl_SetObjLength(commandPtr, --length);
code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
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_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
if ((length > 0) && outChannel) {
Tcl_WriteObj(outChannel, resultPtr);
Tcl_WriteChars(outChannel, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
} else { /* (mainLoopProc != NULL) */
/*
* If a main loop has been defined while running interactively, we
* want to start a fileevent based prompt by establishing a
* channel handler for stdin.
*/
InteractiveState *isPtr = NULL;
if (inChannel) {
if (tty) {
Prompt(interp, &prompt);
}
isPtr = (InteractiveState *)
ckalloc(sizeof(InteractiveState));
isPtr->input = inChannel;
isPtr->tty = tty;
isPtr->commandPtr = commandPtr;
isPtr->prompt = prompt;
isPtr->interp = interp;
Tcl_UnlinkVar(interp, "tcl_interactive");
Tcl_LinkVar(interp, "tcl_interactive", (char *) &(isPtr->tty),
TCL_LINK_BOOLEAN);
Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc,
isPtr);
}
mainLoopProc();
mainLoopProc = NULL;
if (inChannel) {
tty = isPtr->tty;
Tcl_UnlinkVar(interp, "tcl_interactive");
Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty,
TCL_LINK_BOOLEAN);
prompt = isPtr->prompt;
commandPtr = isPtr->commandPtr;
if (isPtr->input != NULL) {
Tcl_DeleteChannelHandler(isPtr->input, StdinProc, isPtr);
}
ckfree((char *) isPtr);
}
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
}
#ifdef TCL_MEM_DEBUG
/*
* This code here only for the (unsupported and deprecated) [checkmem]
* command.
*/
if (tclMemDumpFileName != NULL) {
mainLoopProc = NULL;
Tcl_DeleteInterp(interp);
}
#endif
}
done:
if ((exitCode == 0) && (mainLoopProc != NULL)
&& !Tcl_LimitExceeded(interp)) {
/*
* If everything has gone OK so far, call the main loop proc, if it
* exists. Packages (like Tk) can set it to start processing events at
* this point.
*/
mainLoopProc();
mainLoopProc = NULL;
}
if (commandPtr != NULL) {
Tcl_DecrRefCount(commandPtr);
}
/*
* Rather than calling exit, invoke the "exit" command so that users can
* replace "exit" with some other command to do additional cleanup on
* exit. The Tcl_EvalObjEx call should never return.
*/
if (!Tcl_InterpDeleted(interp)) {
if (!Tcl_LimitExceeded(interp)) {
Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode);
Tcl_IncrRefCount(cmd);
Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmd);
}
/*
* If Tcl_EvalObjEx returns, trying to eval [exit], something unusual
* is happening. Maybe interp has been deleted; maybe [exit] was
* redefined, maybe we've blown up because of an exceeded limit. We
* still want to cleanup and exit.
*/
if (!Tcl_InterpDeleted(interp)) {
Tcl_DeleteInterp(interp);
}
}
Tcl_SetStartupScript(NULL, NULL);
/*
* If we get here, the master interp has been deleted. Allow its
* destruction with the last matching Tcl_Release.
*/
Tcl_Release(interp);
Tcl_Exit(exitCode);
}
void
Tk_MainEx(
int argc, /* Number of arguments. */
TCHAR **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc,
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
Tcl_Interp *interp)
{
Tcl_Obj *path, *argvPtr, *appName;
const char *encodingName;
int code, nullStdin = 0;
Tcl_Channel chan;
InteractiveState is;
/*
* Ensure that we are getting a compatible version of Tcl. This is really
* only an issue when Tk is loaded dynamically.
*/
if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
abort();
}
#if defined(__WIN32__) && !defined(__WIN64__) && !defined(UNICODE) && !defined(STATIC_BUILD)
if (tclStubsPtr->reserved9) {
/* We are running win32 Tk under Cygwin, so let's check
* whether the env("DISPLAY") variable or the -display
* argument is set. If so, we really want to run the
* Tk_MainEx function of libtk8.?.dll, not this one. */
if (Tcl_GetVar2(interp, "env", "DISPLAY", TCL_GLOBAL_ONLY)) {
loadCygwinTk:
if (TkCygwinMainEx(argc, argv, appInitProc, interp)) {
/* Should never reach here. */
return;
}
} else {
int i;
for (i = 1; i < argc; ++i) {
if (!_tcscmp(argv[i], TEXT("-display"))) {
goto loadCygwinTk;
}
}
}
}
#endif
Tcl_InitMemory(interp);
is.interp = interp;
is.gotPartial = 0;
Tcl_Preserve(interp);
#if defined(__WIN32__) && !defined(__CYGWIN__)
Tk_InitConsoleChannels(interp);
#endif
#ifdef MAC_OSX_TK
if (Tcl_GetStartupScript(NULL) == NULL) {
TkMacOSXDefaultStartupScript();
}
#endif
/*
* If the application has not already set a startup script, parse the
* first few command line arguments to determine the script path and
* encoding.
*/
if (NULL == Tcl_GetStartupScript(NULL)) {
size_t length;
/*
* Check whether first 3 args (argv[1] - argv[3]) look like
* -encoding ENCODING FILENAME
* or like
* FILENAME
* or like
* -file FILENAME (ancient history support only)
*/
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& (TEXT('-') != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2], -1);
Tcl_SetStartupScript(NewNativeObj(argv[3], -1), Tcl_GetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
argv += 3;
} else if ((argc > 1) && (TEXT('-') != argv[1][0])) {
Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL);
argc--;
argv++;
} else if ((argc > 2) && (length = _tcslen(argv[1]))
&& (length > 1) && (0 == _tcsncmp(TEXT("-file"), argv[1], length))
&& (TEXT('-') != argv[2][0])) {
Tcl_SetStartupScript(NewNativeObj(argv[2], -1), NULL);
argc -= 2;
argv += 2;
}
}
path = Tcl_GetStartupScript(&encodingName);
if (path == NULL) {
appName = NewNativeObj(argv[0], -1);
} else {
appName = path;
}
Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
argc--;
argv++;
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1));
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
*/
is.tty = isatty(0);
#if defined(MAC_OSX_TK)
/*
* On TkAqua, if we don't have a TTY and stdin is a special character file
* of length 0, (e.g. /dev/null, which is what Finder sets when double
* clicking Wish) then use the GUI console.
*/
if (!is.tty) {
struct stat st;
nullStdin = fstat(0, &st) || (S_ISCHR(st.st_mode) && !st.st_blocks);
}
#endif
Tcl_SetVar2Ex(interp, "tcl_interactive", NULL,
Tcl_NewIntObj(!path && (is.tty || nullStdin)), TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
if (appInitProc(interp) != TCL_OK) {
TkpDisplayWarning(Tcl_GetStringResult(interp),
"application-specific initialization failed");
}
/*
* Invoke the script specified on the command line, if any. Must fetch it
* again, as the appInitProc might have reset it.
*/
path = Tcl_GetStartupScript(&encodingName);
if (path != NULL) {
Tcl_ResetResult(interp);
code = Tcl_FSEvalFileEx(interp, path, encodingName);
if (code != TCL_OK) {
/*
* The following statement guarantees that the errorInfo variable
* is set properly.
*/
Tcl_AddErrorInfo(interp, "");
TkpDisplayWarning(Tcl_GetVar(interp, "errorInfo",
TCL_GLOBAL_ONLY), "Error in startup script");
Tcl_DeleteInterp(interp);
Tcl_Exit(1);
}
is.tty = 0;
} else {
/*
* Evaluate the .rc file, if one has been specified.
*/
Tcl_SourceRCFile(interp);
/*
* Establish a channel handler for stdin.
*/
is.input = Tcl_GetStdChannel(TCL_STDIN);
if (is.input) {
Tcl_CreateChannelHandler(is.input, TCL_READABLE, StdinProc, &is);
}
if (is.tty) {
Prompt(interp, &is);
}
}
chan = Tcl_GetStdChannel(TCL_STDOUT);
if (chan) {
Tcl_Flush(chan);
}
Tcl_DStringInit(&is.command);
Tcl_DStringInit(&is.line);
Tcl_ResetResult(interp);
/*
* Loop infinitely, waiting for commands to execute. When there are no
* windows left, Tk_MainLoop returns and we exit.
*/
Tk_MainLoop();
Tcl_DeleteInterp(interp);
Tcl_Release(interp);
Tcl_SetStartupScript(NULL, NULL);
Tcl_Exit(0);
}
static int
GetProcsCmd(ClientData arg, Tcl_Interp *interp, int argc, char **argv)
{
Tcl_Parse parse;
Tcl_Obj *cmdPtr, *valsPtr[2];
char *p, *vars[2], *next, *script;
char err[100];
int i, n, len;
if (argc != 4) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " script initVar procVar\"", NULL);
return TCL_ERROR;
}
p = argv[1];
n = strlen(p);
/*
* Get the current values of init and procs vars, if any.
*/
argv += 2;
argc -= 2;
for (i = 0; i < argc; ++i) {
vars[i] = argv[i];
valsPtr[i] = Tcl_GetVar2Ex(interp, vars[i], NULL, 0);
}
/*
* Parse and append procs and non-proc command to script vars.
*/
do {
if (Tcl_ParseCommand(interp, p, n, 0, &parse) != TCL_OK) {
sprintf(err, "\n (script offset %d)", p - argv[1]);
Tcl_AddErrorInfo(interp, err);
return TCL_ERROR;
}
if (parse.numWords > 0) {
if (strncmp(parse.tokenPtr->start, "proc", 4) != 0) {
i = 0; /* NB: Append init var. */
} else {
i = 1; /* NB: Append proc var. */
}
/*
* Check that previous script value is newline terminated
* before appending the next command.
*/
if (valsPtr[i] != NULL) {
script = Tcl_GetStringFromObj(valsPtr[i], &len);
if (len > 0 && script[len-1] != '\n'
&& Tcl_SetVar2(interp, vars[i], NULL, "\n",
TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE) == NULL) {
return TCL_ERROR;
}
}
cmdPtr = Tcl_NewStringObj(parse.commandStart, parse.commandSize);
Tcl_IncrRefCount(cmdPtr);
valsPtr[i] = Tcl_SetVar2Ex(interp, vars[i], NULL, cmdPtr,
TCL_APPEND_VALUE|TCL_LEAVE_ERR_MSG);
Tcl_DecrRefCount(cmdPtr);
if (valsPtr[i] == NULL) {
return TCL_ERROR;
}
}
next = parse.commandStart + parse.commandSize;
n -= next - p;
p = next;
Tcl_FreeParse(&parse);
} while (n > 0);
return TCL_OK;
}
int main (int argc,char *argv[])
{
int process_id = 0;
int num_processes = 1;
int par_num_cores, num_threads;
char *env_np;
int *thread_id;
pthread_t *threads;
pthread_attr_t threadattr;
Tcl_Interp *interp;
int i;
char buf[32];
OCpar.isinit = 0;
RFshapes_init();
#ifdef MPI
MPI_Init(NULL, NULL);
//--> might need changes to this:
//int mpi_thread_support;
//MPI_Init_thread(NULL, NULL, MPI_THREAD_MULTIPLE, &mpi_thread_support);
//printf("asked for %d, got %d\n",MPI_THREAD_MULTIPLE,mpi_thread_support);
//if (mpi_thread_support < MPI_THREAD_FUNNELED) {
// fprintf(stderr,"Error: MPI lib doesn't support threads\n");
// exit(1);
//}
//--> end of changes
//--> NOTE: simpson theoretically needs just MPI_THREAD_FUNNELED level of support
MPI_Comm_rank(MPI_COMM_WORLD, &process_id);
MPI_Comm_size(MPI_COMM_WORLD, &num_processes);
char processor_name[MPI_MAX_PROCESSOR_NAME];
int name_len;
MPI_Get_processor_name(processor_name, &name_len);
if (process_id == 0) printf("MPI activated\n-------------\n");
printf("I am process %i of %i running on %s\n", process_id, num_processes, processor_name);
#endif
/* test input arguments */
if (argc >= 2) {
glob_info.mpi_size = num_processes;
glob_info.mpi_rank = process_id;
glob_info.cont_thread = 0;
glob_info.inputfile = strdup(argv[1]);
/* create and initialize master Tcl interpreter */
DEBUGPRINT("Main: creating Tcl interpreter\n");
interp = Tcl_CreateInterp();
if (Tcl_Init(interp) == TCL_ERROR) {
fprintf(stderr,"%s is unable to initialize Tcl interpreter. Is init.tcl on your path?\n",PACKAGE);
fprintf(stderr,"Error: %s\n",Tcl_GetStringResult(interp));
exit(1);
}
TclSimpsonInterpInit(interp);
TclSetSignalHandler(interp,"signalhandler");
/* mark variables that will not be transferred to slaves */
DEBUGPRINT("Main: executing 'markvars'\n");
if (Tcl_Eval(interp, "markvars") != TCL_OK) {
fprintf(stderr,"Error when executing 'markvars':\n%s\n",Tcl_GetStringResult(interp));
exit(1);
}
/* pass input arguments to Tcl interpreter as globals */
DEBUGPRINT("Main: passing input arguments to Tcl interpreter\n");
sprintf(buf,"%d",argc-1);
Tcl_SetVar(interp,"argc",buf,TCL_GLOBAL_ONLY);
Tcl_SetVar(interp,"argv0",argv[1],TCL_GLOBAL_ONLY);
for (i=1; i<argc; i++) {
Tcl_SetVar(interp,"argv",argv[i],TCL_GLOBAL_ONLY|TCL_LIST_ELEMENT|TCL_APPEND_VALUE);
}
if (NULL == Tcl_SetVar(interp,"simpson_version",VERSION,
TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)) {
fprintf(stderr,"error: %s\n",Tcl_GetStringResult(interp));
return TCL_ERROR;
}
/* evaluate input file */
DEBUGPRINT("Main: evaluating input file '%s'\n\n",argv[1]);
if (Tcl_EvalFile(interp, argv[1]) != TCL_OK) {
fprintf(stderr,"Error when evaluating input script %s:\n%s\n",argv[1],Tcl_GetStringResult(interp));
exit(1);
}
/* set par(name) variable */
if (Tcl_Eval(interp, "set par(name) [file rootname [lindex [file split $argv0] end]]") != TCL_OK) {
fprintf(stderr,"Error when setting 'par(name)' variable from argument '%s':\n%s\n",argv[1],Tcl_GetStringResult(interp));
}
#ifdef MPI
/* set par(MPI_rank) and par(MPI_size) */
Tcl_Obj *obj = Tcl_NewIntObj(process_id);
obj = Tcl_SetVar2Ex(interp,"par","MPI_rank",obj,TCL_GLOBAL_ONLY);
if (obj == NULL) {
fprintf(stderr,"Error when setting 'par(MPI_rank)':\n%s\n",Tcl_GetStringResult(interp));
exit(1);
}
obj = Tcl_NewIntObj(num_processes);
obj = Tcl_SetVar2Ex(interp,"par","MPI_size",obj,TCL_GLOBAL_ONLY);
if (obj == NULL) {
fprintf(stderr,"Error when setting 'par(MPI_size)':\n%s\n",Tcl_GetStringResult(interp));
exit(1);
}
#endif
/* set up some globals */
MAXFULLDIM = TclGetInt(interp,"par","maxfulldim",0,10);
MAXDIMDIAGONALIZE = TclGetInt(interp,"par","maxdimdiagonalize",0,4096);
SPARSITY = TclGetDouble(interp,"par","sparsity",0,0.8);
SPARSE_TOL = TclGetDouble(interp,"par","sparse_tol",0,1.0e-6);
/* read par(num_cores) and start threads */
par_num_cores = TclGetInt(interp,"par","num_cores",0,0);
#ifdef WIN32
SYSTEM_INFO sysinfo;
GetSystemInfo( &sysinfo );
num_threads = sysinfo.dwNumberOfProcessors;
#else
num_threads = sysconf (_SC_NPROCESSORS_CONF);
#endif
if ((env_np = getenv("SIMPSON_NUM_CORES")) != NULL){
char *endptr;
num_threads = strtol(env_np, &endptr, 10);
}
if (par_num_cores != 0) num_threads = par_num_cores;
glob_info.num_threads = num_threads;
threads = (pthread_t *) malloc(sizeof(pthread_t) * num_threads);
thread_id = (int *) malloc(sizeof(int) * num_threads);
for (i=0; i<num_threads; i++) thread_id[i] = i;
pthread_barrier_init(&simpson_b_start, NULL, num_threads+1);
pthread_barrier_init(&simpson_b_end, NULL, num_threads+1);
pthread_attr_init(&threadattr);
pthread_attr_setdetachstate(&threadattr, PTHREAD_CREATE_JOINABLE);
for (i=0; i<num_threads; i++) {
pthread_create(&threads[i], &threadattr, (void *)simpson_thread_slave, (void *)(thread_id+i));
}
if (process_id == 0) {
/* MASTER does Tcl main evaluations */
/* execute the 'main' section from input file */
DEBUGPRINT("\n\nMain: evaluating 'main' section\n\n");
if (Tcl_Eval(interp, "main") != TCL_OK) {
fprintf(stderr,"Error when evaluating 'main' section of input script %s:\n%s\n",argv[1],Tcl_GetStringResult(interp));
}
//simpson_fftw_test();
//simpson_nfft_test();
// send message to MPI slaves to terminate (tag = 1)
#ifdef MPI
int terminate = 1;
for (i=1; i< num_processes; i++) {
MPI_Send(&terminate, 1, MPI_INT, i, 1, MPI_COMM_WORLD);
}
#endif
Tcl_DeleteInterp(interp);
DEBUGPRINT("\n\nSuccessful end of %s program!\n",PACKAGE);
} else {
#ifdef MPI
/* slaves jump to simpson() and wait for master */
simpson_mpi_slave(interp);
#endif
}
/* clean up and terminate threads */
glob_info.cont_thread = 0;
pthread_barrier_wait(&simpson_b_start);
for (i=0; i<num_threads; i++) {
pthread_join(threads[i], NULL);
}
DEBUGPRINT("threads successfully terminated.\n");
pthread_attr_destroy(&threadattr);
pthread_barrier_destroy(&simpson_b_start);
pthread_barrier_destroy(&simpson_b_end);
free(threads);
free(thread_id);
} else {
/* not enough arguments */
if (process_id == 0) {
fprintf(stderr,"%s version %s, Copyright (C)\n",PACKAGE,VERSION);
fprintf(stderr,"1999-2000 Mads Bak and Jimmy T. Rasmussen\n"
"2001 Mads Bak and Thomas Vosegaard\n"
"2002-2007 Thomas Vosegaard\n"
"2008-2009 Zdenek Tosner, Thomas Vosegaard, and Niels Chr. Nielsen\n"
"2009 plus Rasmus Andersen\n"
"2010-2014 Zdenek Tosner, Niels Chr. Nielsen, Thomas Vosegaard\n");
fprintf(stderr,"%s comes with ABSOLUTELY NO WARRANTY, for details\n",PACKAGE);
fprintf(stderr,"read the COPYING file included in this distribution.\n"
"This is free software, and you are welcome to redistribute\n"
"it under certain conditions according to the GNU General Public License.\n"
"\nPlease specify an inputfile, optionally with other arguments.\n");
}
}
/* clean up and terminate */
#ifdef MPI
MPI_Finalize();
#endif
return 0;
}
void
TclpSetVariables(
Tcl_Interp *interp) /* Interp to initialize. */
{
const char *ptr;
char buffer[TCL_INTEGER_SPACE * 2];
SYSTEM_INFO sysInfo, *sysInfoPtr = &sysInfo;
OemId *oemId;
OSVERSIONINFOA osInfo;
Tcl_DString ds;
WCHAR szUserName[UNLEN+1];
DWORD cchUserNameLen = UNLEN;
Tcl_SetVar2Ex(interp, "tclDefaultLibrary", NULL,
TclGetProcessGlobalValue(&defaultLibraryDir), TCL_GLOBAL_ONLY);
osInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA);
GetVersionExA(&osInfo);
oemId = (OemId *) sysInfoPtr;
GetSystemInfo(&sysInfo);
/*
* Define the tcl_platform array.
*/
Tcl_SetVar2(interp, "tcl_platform", "platform", "windows",
TCL_GLOBAL_ONLY);
if (osInfo.dwPlatformId < NUMPLATFORMS) {
Tcl_SetVar2(interp, "tcl_platform", "os",
platforms[osInfo.dwPlatformId], TCL_GLOBAL_ONLY);
}
wsprintfA(buffer, "%d.%d", osInfo.dwMajorVersion, osInfo.dwMinorVersion);
Tcl_SetVar2(interp, "tcl_platform", "osVersion", buffer, TCL_GLOBAL_ONLY);
if (oemId->wProcessorArchitecture < NUMPROCESSORS) {
Tcl_SetVar2(interp, "tcl_platform", "machine",
processors[oemId->wProcessorArchitecture],
TCL_GLOBAL_ONLY);
}
#ifdef _DEBUG
/*
* The existence of the "debug" element of the tcl_platform array
* indicates that this particular Tcl shell has been compiled with debug
* information. Using "info exists tcl_platform(debug)" a Tcl script can
* direct the interpreter to load debug versions of DLLs with the load
* command.
*/
Tcl_SetVar2(interp, "tcl_platform", "debug", "1",
TCL_GLOBAL_ONLY);
#endif
/*
* Set up the HOME environment variable from the HOMEDRIVE & HOMEPATH
* environment variables, if necessary.
*/
Tcl_DStringInit(&ds);
ptr = Tcl_GetVar2(interp, "env", "HOME", TCL_GLOBAL_ONLY);
if (ptr == NULL) {
ptr = Tcl_GetVar2(interp, "env", "HOMEDRIVE", TCL_GLOBAL_ONLY);
if (ptr != NULL) {
Tcl_DStringAppend(&ds, ptr, -1);
}
ptr = Tcl_GetVar2(interp, "env", "HOMEPATH", TCL_GLOBAL_ONLY);
if (ptr != NULL) {
Tcl_DStringAppend(&ds, ptr, -1);
}
if (Tcl_DStringLength(&ds) > 0) {
Tcl_SetVar2(interp, "env", "HOME", Tcl_DStringValue(&ds),
TCL_GLOBAL_ONLY);
} else {
Tcl_SetVar2(interp, "env", "HOME", "c:\\", TCL_GLOBAL_ONLY);
}
}
/*
* Initialize the user name from the environment first, since this is much
* faster than asking the system.
* Note: cchUserNameLen is number of characters including nul terminator.
*/
Tcl_DStringInit(&ds);
if (TclGetEnv("USERNAME", &ds) == NULL) {
if (tclWinProcs->getUserName((LPTSTR)szUserName, &cchUserNameLen) != 0) {
int cbUserNameLen = cchUserNameLen - 1;
if (tclWinProcs->useWide) cbUserNameLen *= sizeof(WCHAR);
Tcl_WinTCharToUtf((LPTSTR)szUserName, cbUserNameLen, &ds);
}
}
Tcl_SetVar2(interp, "tcl_platform", "user", Tcl_DStringValue(&ds),
TCL_GLOBAL_ONLY);
Tcl_DStringFree(&ds);
/*
* Define what the platform PATH separator is. [TIP #315]
*/
Tcl_SetVar2(interp, "tcl_platform","pathSeparator", ";", TCL_GLOBAL_ONLY);
}
void
Tk_MainEx(
int argc, /* Number of arguments. */
char **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc,
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
Tcl_Interp *interp)
{
Tcl_Obj *path, *argvPtr;
const char *encodingName;
int code, nullStdin = 0;
Tcl_Channel inChannel, outChannel;
ThreadSpecificData *tsdPtr;
#ifdef __WIN32__
HANDLE handle;
#endif
Tcl_DString appName;
/*
* Ensure that we are getting a compatible version of Tcl. This is really
* only an issue when Tk is loaded dynamically.
*/
if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
abort();
}
tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
Tcl_FindExecutable(argv[0]);
tsdPtr->interp = interp;
Tcl_Preserve(interp);
#if defined(__WIN32__)
Tk_InitConsoleChannels(interp);
#endif
#ifdef MAC_OSX_TK
if (Tcl_GetStartupScript(NULL) == NULL) {
TkMacOSXDefaultStartupScript();
}
#endif
#ifdef TCL_MEM_DEBUG
Tcl_InitMemory(interp);
#endif
/*
* If the application has not already set a startup script, parse the
* first few command line arguments to determine the script path and
* encoding.
*/
if (NULL == Tcl_GetStartupScript(NULL)) {
size_t length;
/*
* Check whether first 3 args (argv[1] - argv[3]) look like
* -encoding ENCODING FILENAME
* or like
* FILENAME
* or like
* -file FILENAME (ancient history support only)
*/
if ((argc > 3) && (0 == strcmp("-encoding", argv[1]))
&& ('-' != argv[3][0])) {
Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]);
argc -= 3;
argv += 3;
} else if ((argc > 1) && ('-' != argv[1][0])) {
Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL);
argc--;
argv++;
} else if ((argc > 2) && (length = strlen(argv[1]))
&& (length > 1) && (0 == strncmp("-file", argv[1], length))
&& ('-' != argv[2][0])) {
Tcl_SetStartupScript(Tcl_NewStringObj(argv[2], -1), NULL);
argc -= 2;
argv += 2;
}
}
path = Tcl_GetStartupScript(&encodingName);
if (NULL == path) {
Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName);
} else {
int numBytes;
const char *pathName = Tcl_GetStringFromObj(path, &numBytes);
Tcl_ExternalToUtfDString(NULL, pathName, numBytes, &appName);
path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1);
Tcl_SetStartupScript(path, encodingName);
}
Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY);
Tcl_DStringFree(&appName);
argc--;
argv++;
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_DString ds;
Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds);
Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj(
Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
Tcl_DStringFree(&ds);
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
*/
#ifdef __WIN32__
/*
* For now, under Windows, we assume we are not running as a console mode
* app, so we need to use the GUI console. In order to enable this, we
* always claim to be running on a tty. This probably isn't the right way
* to do it.
*/
handle = GetStdHandle(STD_INPUT_HANDLE);
if ((handle == INVALID_HANDLE_VALUE) || (handle == 0)
|| (GetFileType(handle) == FILE_TYPE_UNKNOWN)) {
/*
* If it's a bad or closed handle, then it's been connected to a wish
* console window.
*/
tsdPtr->tty = 1;
} else if (GetFileType(handle) == FILE_TYPE_CHAR) {
/*
* A character file handle is a tty by definition.
*/
tsdPtr->tty = 1;
} else {
tsdPtr->tty = 0;
}
#else
tsdPtr->tty = isatty(0);
#endif
#if defined(MAC_OSX_TK)
/*
* On TkAqua, if we don't have a TTY and stdin is a special character file
* of length 0, (e.g. /dev/null, which is what Finder sets when double
* clicking Wish) then use the GUI console.
*/
if (!tsdPtr->tty) {
struct stat st;
nullStdin = fstat(0, &st) || (S_ISCHR(st.st_mode) && !st.st_blocks);
}
#endif
Tcl_SetVar(interp, "tcl_interactive",
((path == NULL) && (tsdPtr->tty || nullStdin)) ? "1" : "0",
TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
if (appInitProc(interp) != TCL_OK) {
TkpDisplayWarning(Tcl_GetStringResult(interp),
"Application initialization failed");
}
/*
* Invoke the script specified on the command line, if any. Must fetch it
* again, as the appInitProc might have reset it.
*/
path = Tcl_GetStartupScript(&encodingName);
if (path != NULL) {
Tcl_ResetResult(interp);
code = Tcl_FSEvalFileEx(interp, path, encodingName);
if (code != TCL_OK) {
/*
* The following statement guarantees that the errorInfo variable
* is set properly.
*/
Tcl_AddErrorInfo(interp, "");
TkpDisplayWarning(Tcl_GetVar(interp, "errorInfo",
TCL_GLOBAL_ONLY), "Error in startup script");
Tcl_DeleteInterp(interp);
Tcl_Exit(1);
}
tsdPtr->tty = 0;
} else {
/*
* Evaluate the .rc file, if one has been specified.
*/
Tcl_SourceRCFile(interp);
/*
* Establish a channel handler for stdin.
*/
inChannel = Tcl_GetStdChannel(TCL_STDIN);
if (inChannel) {
Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc,
inChannel);
}
if (tsdPtr->tty) {
Prompt(interp, 0);
}
}
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
if (outChannel) {
Tcl_Flush(outChannel);
}
Tcl_DStringInit(&tsdPtr->command);
Tcl_DStringInit(&tsdPtr->line);
Tcl_ResetResult(interp);
/*
* Loop infinitely, waiting for commands to execute. When there are no
* windows left, Tk_MainLoop returns and we exit.
*/
Tk_MainLoop();
Tcl_DeleteInterp(interp);
Tcl_Release(interp);
Tcl_SetStartupScript(NULL, NULL);
Tcl_Exit(0);
}
int
BasicGFunEvaluator::elementTclVariable(int eleNumber, char* varName, char* inString)
{
// now obtain the information directly from domain without creating recorder files
Element *theElement = theOpenSeesDomain->getElement(eleNumber);
if (theElement == 0) {
opserr << "GFunEvaluator::elementTclVariable -- element with tag " << eleNumber
<< " not found in OpenSees Domain" << endln;
return 0;
}
int rowNumber; // index into vector containing element response
const int argvLength = 20;
const int argcMax = 10;
char workspace[argcMax*argvLength];
char *argv[argcMax];
for (int i = 0; i < argcMax; i++)
argv[i] = &workspace[i*argvLength];
int argc = 0;
char restString[100];
strcpy(restString, inString);
if ( strncmp(restString, "section",7) == 0) {
int sectionNumber;
sscanf(restString,"section_%i_%s", §ionNumber, restString);
strcpy(argv[0], "section");
sprintf(argv[1], "%d", sectionNumber);
if ( strncmp(restString, "force",5) == 0) {
sscanf(restString,"force_%i", &rowNumber);
strcpy(argv[2], "force");
sprintf(argv[3], "%d", rowNumber);
argc = 4;
}
else if ( strncmp(restString, "deformation",11) == 0) {
sscanf(restString,"deformation_%i", &rowNumber);
strcpy(argv[2], "deformation");
sprintf(argv[3], "%d", rowNumber);
argc = 4;
}
else if ( strncmp(restString, "fiber",5) == 0) {
int ya, yb, za, zb;
sscanf(restString,"fiber_%i_%i_%i_%i_%s", &ya, &yb, &za, &zb, restString);
strcpy(argv[2],"fiber");
sprintf(argv[3],"%d.%d", ya, yb);
sprintf(argv[4],"%d.%d", za, zb);
if (strncmp(restString,"stress",6)==0) {
strcpy(argv[5],"stress");
rowNumber = 1;
argc = 6;
}
else if (strncmp(restString,"strain",6)==0) {
strcpy(argv[5],"strain");
rowNumber = 2;
argc = 6;
}
else {
opserr << "ERROR in syntax of limit-state function for element response quantity." << endln;
}
}
}
else {
// should work for any user input response quantity type (as long as element supports it)
char responseType[30] = "";
char* tokstr = strtok(restString,"_");
strcpy(responseType,tokstr);
tokstr = strtok(NULL,"_");
if (tokstr != NULL)
rowNumber = atoi(tokstr);
strcpy(argv[0], responseType);
sprintf(argv[1], "%d", rowNumber);
argc = 2;
}
char arrName[100];
sprintf(arrName,"%i,%s",eleNumber,inString);
opserr << "var = " << varName << " and array = " << arrName << endln;
// add the element get and set response
DummyStream theHandler;
Response *theResponse;
theResponse = theElement->setResponse((const char **)argv, argc, theHandler);
double gFunValue = 0.0;
if (theResponse != 0) {
theResponse->getResponse();
Information &eleInfo = theResponse->getInformation();
const Vector &eleData = eleInfo.getData();
if (eleData.Size() > 0)
gFunValue = eleData(rowNumber-1); // C-index
delete theResponse;
}
// set tcl variable
if (Tcl_SetVar2Ex(theTclInterp,varName,arrName,Tcl_NewDoubleObj(gFunValue),TCL_LEAVE_ERR_MSG) == NULL) {
opserr << "GFunEvaluator::elementTclVariable -- SetVar error" << endln;
opserr << theTclInterp->result << endln;
return -1;
}
return 0;
}
/*-----------------------------------------------------------------------------
* ReturnStatArray --
*
* Return file stat infomation in an array.
*
* Parameters:
* o interp (I) - Current interpreter, error return in result.
* o ttyDev (O) - A boolean indicating if the device is associated with a
* tty.
* o statBufPtr (I) - Pointer to a buffer initialized by stat or fstat.
* o arrayObj (I) - The the array to return the info in.
* Returns:
* TCL_OK or TCL_ERROR.
*-----------------------------------------------------------------------------
*/
static int
ReturnStatArray (Tcl_Interp *interp,
int ttyDev,
struct stat *statBufPtr,
Tcl_Obj *arrayObj)
{
char *varName = Tcl_GetStringFromObj (arrayObj, NULL);
if (Tcl_SetVar2Ex(interp, varName, "dev",
Tcl_NewIntObj((int)statBufPtr->st_dev),
TCL_LEAVE_ERR_MSG) == NULL)
goto errorExit;
if (Tcl_SetVar2Ex(interp, varName, "ino",
Tcl_NewIntObj((int)statBufPtr->st_ino),
TCL_LEAVE_ERR_MSG) == NULL)
goto errorExit;
if (Tcl_SetVar2Ex(interp, varName, "mode",
Tcl_NewIntObj((int)statBufPtr->st_mode),
TCL_LEAVE_ERR_MSG) == NULL)
goto errorExit;
if (Tcl_SetVar2Ex(interp, varName, "nlink",
Tcl_NewIntObj((int)statBufPtr->st_nlink),
TCL_LEAVE_ERR_MSG) == NULL)
goto errorExit;
if (Tcl_SetVar2Ex(interp, varName, "uid",
Tcl_NewIntObj((int)statBufPtr->st_uid),
TCL_LEAVE_ERR_MSG) == NULL)
goto errorExit;
if (Tcl_SetVar2Ex(interp, varName, "gid",
Tcl_NewIntObj((int)statBufPtr->st_gid),
TCL_LEAVE_ERR_MSG) == NULL)
goto errorExit;
if (Tcl_SetVar2Ex(interp, varName, "size",
Tcl_NewLongObj((long)statBufPtr->st_size),
TCL_LEAVE_ERR_MSG) == NULL)
goto errorExit;
if (Tcl_SetVar2Ex(interp, varName, "atime",
Tcl_NewLongObj((long)statBufPtr->st_atime),
TCL_LEAVE_ERR_MSG) == NULL)
goto errorExit;
if (Tcl_SetVar2Ex(interp, varName, "mtime",
Tcl_NewLongObj((long)statBufPtr->st_mtime),
TCL_LEAVE_ERR_MSG) == NULL)
goto errorExit;
if (Tcl_SetVar2Ex(interp, varName, "ctime",
Tcl_NewLongObj((long)statBufPtr->st_ctime),
TCL_LEAVE_ERR_MSG) == NULL)
goto errorExit;
if (Tcl_SetVar2Ex(interp, varName, "tty",
Tcl_NewBooleanObj(ttyDev),
TCL_LEAVE_ERR_MSG) == NULL)
goto errorExit;
if (Tcl_SetVar2Ex(interp, varName, "type",
Tcl_NewStringObj(StrFileType(statBufPtr), -1),
TCL_LEAVE_ERR_MSG) == NULL)
goto errorExit;
return TCL_OK;
errorExit:
return TCL_ERROR;
}
int
mongotcl_bsontoarray_raw (Tcl_Interp *interp, char *arrayName, char *typeArrayName, const char *data , int depth) {
bson_iterator i;
const char *key;
bson_timestamp_t ts;
char oidhex[25];
Tcl_Obj *obj;
char *type;
if (data == NULL) {
return TCL_OK;
}
bson_iterator_from_buffer(&i, data);
while (bson_iterator_next (&i)) {
bson_type t = bson_iterator_type (&i);
if (t == 0) {
break;
}
key = bson_iterator_key (&i);
switch (t) {
case BSON_DOUBLE: {
obj = Tcl_NewDoubleObj (bson_iterator_double (&i));
type = "double";
break;
}
case BSON_SYMBOL: {
obj = Tcl_NewStringObj (bson_iterator_string (&i), -1);
type = "symbol";
break;
}
case BSON_STRING: {
obj = Tcl_NewStringObj (bson_iterator_string (&i), -1);
type = "string";
break;
}
case BSON_OID: {
bson_oid_to_string( bson_iterator_oid( &i ), oidhex );
obj = Tcl_NewStringObj (oidhex, -1);
type = "oid";
break;
}
case BSON_BOOL: {
obj = Tcl_NewBooleanObj (bson_iterator_bool (&i));
type = "bool";
break;
}
case BSON_DATE: {
obj = Tcl_NewLongObj ((long) bson_iterator_date(&i));
type = "date";
break;
}
case BSON_BINDATA: {
unsigned char *bindata = (unsigned char *)bson_iterator_bin_data (&i);
int binlen = bson_iterator_bin_len (&i);
obj = Tcl_NewByteArrayObj (bindata, binlen);
type = "bin";
break;
}
case BSON_UNDEFINED: {
obj = Tcl_NewObj ();
type = "undefined";
break;
}
case BSON_NULL: {
obj = Tcl_NewObj ();
type = "null";
break;
}
case BSON_REGEX: {
obj = Tcl_NewStringObj (bson_iterator_regex (&i), -1);
type = "regex";
break;
}
case BSON_CODE: {
obj = Tcl_NewStringObj (bson_iterator_code (&i), -1);
type = "code";
break;
}
case BSON_CODEWSCOPE: {
// bson_printf( "BSON_CODE_W_SCOPE: %s", bson_iterator_code( &i ) );
/* bson_init( &scope ); */ /* review - stepped on by bson_iterator_code_scope? */
// bson_iterator_code_scope( &i, &scope );
// bson_printf( "\n\t SCOPE: " );
// bson_print( &scope );
/* bson_destroy( &scope ); */ /* review - causes free error */
break;
}
case BSON_INT: {
obj = Tcl_NewIntObj (bson_iterator_int (&i));
type = "int";
break;
}
case BSON_LONG: {
obj = Tcl_NewLongObj ((uint64_t)bson_iterator_long (&i));
type = "long";
break;
}
case BSON_TIMESTAMP: {
char string[64];
ts = bson_iterator_timestamp (&i);
snprintf(string, sizeof(string), "%d:%d", ts.i, ts.t);
obj = Tcl_NewStringObj (bson_iterator_string (&i), -1);
type = "timestamp";
break;
}
case BSON_ARRAY: {
obj = Tcl_NewObj();
obj = mongotcl_bsontolist_raw (interp, obj, bson_iterator_value (&i), depth + 1);
type = "array";
break;
}
case BSON_OBJECT: {
Tcl_Obj *subList = Tcl_NewObj ();
obj = mongotcl_bsontolist_raw (interp, subList, bson_iterator_value (&i), depth + 1);
type = "object";
break;
}
default: {
obj = Tcl_NewIntObj (t);
type = "unknown";
break;
}
}
if (Tcl_SetVar2Ex (interp, arrayName, key, obj, TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
if (typeArrayName != NULL) {
if (Tcl_SetVar2Ex (interp, typeArrayName, key, Tcl_NewStringObj (type, -1), TCL_LEAVE_ERR_MSG) == NULL) {
return TCL_ERROR;
}
}
}
return TCL_OK;
}
void
Tcl_MainEx(
int argc, /* Number of arguments. */
TCHAR **argv, /* Array of argument strings. */
Tcl_AppInitProc *appInitProc,
/* Application-specific initialization
* function to call after most initialization
* but before starting to execute commands. */
Tcl_Interp *interp)
{
Tcl_Obj *path, *resultPtr, *argvPtr, *appName;
const char *encodingName = NULL;
int code, exitCode = 0;
Tcl_MainLoopProc *mainLoopProc;
Tcl_Channel chan;
InteractiveState is;
TclpSetInitialEncodings();
TclpFindExecutable((const char *)argv[0]);
Tcl_InitMemory(interp);
is.interp = interp;
is.prompt = PROMPT_START;
is.commandPtr = Tcl_NewObj();
/*
* If the application has not already set a startup script, parse the
* first few command line arguments to determine the script path and
* encoding.
*/
if (NULL == Tcl_GetStartupScript(NULL)) {
/*
* Check whether first 3 args (argv[1] - argv[3]) look like
* -encoding ENCODING FILENAME
* or like
* FILENAME
*/
if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
&& ('-' != argv[3][0])) {
Tcl_Obj *value = NewNativeObj(argv[2], -1);
Tcl_SetStartupScript(NewNativeObj(argv[3], -1),
Tcl_GetString(value));
Tcl_DecrRefCount(value);
argc -= 3;
argv += 3;
} else if ((argc > 1) && ('-' != argv[1][0])) {
Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL);
argc--;
argv++;
}
}
path = Tcl_GetStartupScript(&encodingName);
if (path == NULL) {
appName = NewNativeObj(argv[0], -1);
} else {
appName = path;
}
Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
argc--;
argv++;
Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY);
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1));
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
/*
* Set the "tcl_interactive" variable.
*/
is.tty = isatty(0);
Tcl_SetVar2Ex(interp, "tcl_interactive", NULL,
Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY);
/*
* Invoke application-specific initialization.
*/
Tcl_Preserve(interp);
if (appInitProc(interp) != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteChars(chan,
"application-specific initialization failed: ", -1);
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
}
if (Tcl_InterpDeleted(interp)) {
goto done;
}
if (Tcl_LimitExceeded(interp)) {
goto done;
}
if (TclFullFinalizationRequested()) {
/*
* Arrange for final deletion of the main interp
*/
/* ARGH Munchhausen effect */
Tcl_CreateExitHandler(FreeMainInterp, interp);
}
/*
* Invoke the script specified on the command line, if any. Must fetch it
* again, as the appInitProc might have reset it.
*/
path = Tcl_GetStartupScript(&encodingName);
if (path != NULL) {
Tcl_ResetResult(interp);
code = Tcl_FSEvalFileEx(interp, path, encodingName);
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
Tcl_Obj *keyPtr, *valuePtr;
TclNewLiteralStringObj(keyPtr, "-errorinfo");
Tcl_IncrRefCount(keyPtr);
Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr);
Tcl_DecrRefCount(keyPtr);
if (valuePtr) {
Tcl_WriteObj(chan, valuePtr);
}
Tcl_WriteChars(chan, "\n", 1);
Tcl_DecrRefCount(options);
}
exitCode = 1;
}
goto done;
}
/*
* We're running interactively. Source a user-specific startup file if the
* application specified one and if the file exists.
*/
Tcl_SourceRCFile(interp);
if (Tcl_LimitExceeded(interp)) {
goto done;
}
/*
* 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.
*/
Tcl_IncrRefCount(is.commandPtr);
/*
* Get a new value for tty if anyone writes to ::tcl_interactive
*/
Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN);
is.input = Tcl_GetStdChannel(TCL_STDIN);
while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
mainLoopProc = TclGetMainLoop();
if (mainLoopProc == NULL) {
int length;
if (is.tty) {
Prompt(interp, &is);
if (Tcl_InterpDeleted(interp)) {
break;
}
if (Tcl_LimitExceeded(interp)) {
break;
}
is.input = Tcl_GetStdChannel(TCL_STDIN);
if (is.input == NULL) {
break;
}
}
if (Tcl_IsShared(is.commandPtr)) {
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
Tcl_IncrRefCount(is.commandPtr);
}
length = Tcl_GetsObj(is.input, is.commandPtr);
if (length < 0) {
if (Tcl_InputBlocked(is.input)) {
/*
* This can only happen if stdin has been set to
* non-blocking. In that case cycle back and try again.
* This sets up a tight polling loop (since we have no
* event loop running). If this causes bad CPU hogging, we
* might try toggling the blocking on stdin instead.
*/
continue;
}
/*
* Either EOF, or an error on stdin; we're done
*/
break;
}
/*
* Add the newline removed by Tcl_GetsObj back to the string. Have
* to add it back before testing completeness, because it can make
* a difference. [Bug 1775878]
*/
if (Tcl_IsShared(is.commandPtr)) {
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
Tcl_IncrRefCount(is.commandPtr);
}
Tcl_AppendToObj(is.commandPtr, "\n", 1);
if (!TclObjCommandComplete(is.commandPtr)) {
is.prompt = PROMPT_CONTINUE;
continue;
}
is.prompt = PROMPT_START;
/*
* The final newline is syntactically redundant, and causes some
* error messages troubles deeper in, so lop it back off.
*/
Tcl_GetStringFromObj(is.commandPtr, &length);
Tcl_SetObjLength(is.commandPtr, --length);
code = Tcl_RecordAndEvalObj(interp, is.commandPtr,
TCL_EVAL_GLOBAL);
is.input = Tcl_GetStdChannel(TCL_STDIN);
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = Tcl_NewObj();
Tcl_IncrRefCount(is.commandPtr);
if (code != TCL_OK) {
chan = Tcl_GetStdChannel(TCL_STDERR);
if (chan) {
Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
Tcl_WriteChars(chan, "\n", 1);
}
} else if (is.tty) {
resultPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(resultPtr);
Tcl_GetStringFromObj(resultPtr, &length);
chan = Tcl_GetStdChannel(TCL_STDOUT);
if ((length > 0) && chan) {
Tcl_WriteObj(chan, resultPtr);
Tcl_WriteChars(chan, "\n", 1);
}
Tcl_DecrRefCount(resultPtr);
}
} else { /* (mainLoopProc != NULL) */
/*
* If a main loop has been defined while running interactively, we
* want to start a fileevent based prompt by establishing a
* channel handler for stdin.
*/
if (is.input) {
if (is.tty) {
Prompt(interp, &is);
}
Tcl_CreateChannelHandler(is.input, TCL_READABLE,
StdinProc, &is);
}
mainLoopProc();
Tcl_SetMainLoop(NULL);
if (is.input) {
Tcl_DeleteChannelHandler(is.input, StdinProc, &is);
}
is.input = Tcl_GetStdChannel(TCL_STDIN);
}
/*
* This code here only for the (unsupported and deprecated) [checkmem]
* command.
*/
#ifdef TCL_MEM_DEBUG
if (tclMemDumpFileName != NULL) {
Tcl_SetMainLoop(NULL);
Tcl_DeleteInterp(interp);
}
#endif /* TCL_MEM_DEBUG */
}
done:
mainLoopProc = TclGetMainLoop();
if ((exitCode == 0) && mainLoopProc && !Tcl_LimitExceeded(interp)) {
/*
* If everything has gone OK so far, call the main loop proc, if it
* exists. Packages (like Tk) can set it to start processing events at
* this point.
*/
mainLoopProc();
Tcl_SetMainLoop(NULL);
}
if (is.commandPtr != NULL) {
Tcl_DecrRefCount(is.commandPtr);
}
/*
* Rather than calling exit, invoke the "exit" command so that users can
* replace "exit" with some other command to do additional cleanup on
* exit. The Tcl_EvalObjEx call should never return.
*/
if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) {
Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode);
Tcl_IncrRefCount(cmd);
Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmd);
}
/*
* If Tcl_EvalObjEx returns, trying to eval [exit], something unusual is
* happening. Maybe interp has been deleted; maybe [exit] was redefined,
* maybe we've blown up because of an exceeded limit. We still want to
* cleanup and exit.
*/
Tcl_Exit(exitCode);
}
static int configure( Tcl_Interp *interp, SpinButtonParams *para,
GnoclOption options[] )
{
int ret = TCL_ERROR;
int blocked = 0;
int setAdjust = 0;
GtkAdjustment *oldAdjust = gtk_spin_button_get_adjustment(
para->spinButton );
gfloat lower = oldAdjust->lower;
gfloat upper = oldAdjust->upper;
gfloat stepInc = oldAdjust->step_increment;
gfloat pageInc = oldAdjust->page_increment;
if( gnoclSetOptions( interp, options, G_OBJECT( para->spinButton ), -1 )
!= TCL_OK )
goto cleanExit;
gnoclAttacheOptCmdAndVar( options + onValueChangedIdx, ¶->onValueChanged,
options + variableIdx, ¶->variable,
"value-changed", G_OBJECT( para->spinButton ),
G_CALLBACK( changedFunc ), interp, traceFunc, para );
if( para->onValueChanged != NULL )
{
blocked = g_signal_handlers_block_matched(
G_OBJECT( para->spinButton ), G_SIGNAL_MATCH_FUNC,
0, 0, NULL, (gpointer *)changedFunc, NULL );
}
if( options[valueIdx].status == GNOCL_STATUS_CHANGED )
{
assert( strcmp( options[valueIdx].optName, "-value" ) == 0 );
gtk_spin_button_set_value( para->spinButton, options[valueIdx].val.d );
if( para->variable )
{
Tcl_Obj *obj = getObjValue( para->spinButton );
para->inSetVar++;
obj = Tcl_SetVar2Ex( para->interp, para->variable, NULL, obj,
TCL_GLOBAL_ONLY );
para->inSetVar--;
if( obj == NULL )
goto cleanExit;
}
}
/* if variable is set, synchronize variable and widget */
if( options[variableIdx].status == GNOCL_STATUS_CHANGED
&& para->variable != NULL
&& options[valueIdx].status != GNOCL_STATUS_CHANGED )
{
Tcl_Obj *var = Tcl_GetVar2Ex( interp, para->variable, NULL,
TCL_GLOBAL_ONLY );
assert( strcmp( options[variableIdx].optName, "-variable" ) == 0 );
if( var == NULL ) /* variable does not yet exist */
{
Tcl_Obj *obj = getObjValue( para->spinButton );
para->inSetVar++;
obj = Tcl_SetVar2Ex( para->interp, para->variable, NULL, obj,
TCL_GLOBAL_ONLY );
para->inSetVar--;
if( obj == NULL )
goto cleanExit;
}
else
{
double d;
if( Tcl_GetDoubleFromObj( interp, var, &d ) != TCL_OK )
goto cleanExit;
gtk_spin_button_set_value( para->spinButton, d );
}
}
if( options[lowerIdx].status == GNOCL_STATUS_CHANGED )
{
assert( strcmp( options[lowerIdx].optName, "-lower" ) == 0 );
lower = options[lowerIdx].val.d;
setAdjust = 1;
}
if( options[upperIdx].status == GNOCL_STATUS_CHANGED )
{
assert( strcmp( options[upperIdx].optName, "-upper" ) == 0 );
upper = options[upperIdx].val.d;
setAdjust = 1;
}
if( options[stepIncIdx].status == GNOCL_STATUS_CHANGED )
{
assert( strcmp( options[stepIncIdx].optName, "-stepInc" ) == 0 );
stepInc = options[stepIncIdx].val.d;
setAdjust = 1;
}
if( options[pageIncIdx].status == GNOCL_STATUS_CHANGED )
{
assert( strcmp( options[pageIncIdx].optName, "-pageInc" ) == 0 );
pageInc = options[pageIncIdx].val.d;
setAdjust = 1;
}
if( setAdjust )
{
/* see also scale.c */
/* last parameter is pageSize, where it is used? */
gtk_spin_button_set_adjustment( para->spinButton,
GTK_ADJUSTMENT( gtk_adjustment_new( oldAdjust->value, lower, upper,
stepInc, pageInc, 0 ) ) );
/* gtk_spin_button_update( para->spinButton ); */
}
/*
spinButtonTraceFunc( para, interp, para->variable, NULL, 0 );
*/
ret = TCL_OK;
cleanExit:
if( blocked )
{
g_signal_handlers_unblock_matched(
G_OBJECT( para->spinButton ), G_SIGNAL_MATCH_FUNC, 0,
0, NULL, (gpointer *)changedFunc, NULL );
}
return ret;
}
