/****************************************************
CLEAN_CELL
****************************************************/
void clean_cell( object *root, char *tag, char *lab )
{
char ch1[ 2 * MAX_ELEM_LENGTH ];
int j, i;
object *cur;
variable *cv;
cur = root->search( lab );
for ( i = 1; i <= MAX_COLS && cur != NULL; cur = cur->hyper_next( lab ), ++i )
{
for ( cv = cur->v; cv != NULL; cv = cv->next )
{
if ( cv->param == 1 )
{
sprintf( ch1,"p%s_%d", cv->label, i );
cmd( "set %s [ $w.c%d_v%sp get ]", ch1, i, cv->label );
Tcl_UnlinkVar( inter, ch1 );
}
else
{
for ( j = 0; j < cv->num_lag; ++j )
{
sprintf( ch1,"v%s_%d_%d", cv->label, i, j );
cmd( "set %s [ $w.c%d_v%s_%d get ]", ch1, i, cv->label, j );
Tcl_UnlinkVar( inter, ch1 );
}
}
}
}
}
void geo_free_groups( group_t *groups )
{
group_t *grp;
int gid = 0;
char str[64];
for( ; groups != NULL; gid++ )
{
grp = groups->Next;
sprintf( str, "GroupStatus(%d)", gid );
Tcl_UnlinkVar( TCLInterp, str );
free( groups );
groups = grp;
}
Tcl_SetVar( TCLInterp, "NumberOfGroups", "0", TCL_GLOBAL_ONLY );
}
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);
}
/****************************************************
EDIT_DATA
****************************************************/
void edit_data( object *root, int *choice, char *obj_name )
{
char *l , ch[ 2 * MAX_ELEM_LENGTH ], ch1[ MAX_ELEM_LENGTH ];
int i, counter, lag;
object *first;
cmd( "if {$tcl_platform(os) == \"Darwin\"} {set cwidth 9; set cbd 2 } {set cwidth 8; set cbd 2}" );
Tcl_LinkVar( inter, "lag", ( char * ) &lag, TCL_LINK_INT );
cmd( "if { ! [ info exists autoWidth ] } { set autoWidth 1 }" );
cmd( "if { ! [ winfo exists .ini ] } { newtop .ini; showtop .ini topleftW 1 1 1 $hsizeI $vsizeI } { if { ! $autoWidth } { resizetop $hsizeI $vsizeI } }" );
cmd( "set position 1.0" );
in_edit_data = true;
*choice = 0;
while ( *choice == 0 )
{
// reset title and destroy command because may be coming from set_obj_number
cmd( "settop .ini \"%s%s - LSD Initial Values Editor\" { set choice 1 }", unsaved_change() ? "*" : " ", simul_name );
first = root->search( obj_name );
cmd( "frame .ini.b" );
cmd( "set w .ini.b.tx" );
cmd( "scrollbar .ini.b.ys -command \".ini.b.tx yview\"" );
cmd( "scrollbar .ini.b.xs -command \".ini.b.tx xview\" -orient horizontal" );
cmd( "text $w -yscrollcommand \".ini.b.ys set\" -xscrollcommand \".ini.b.xs set\" -wrap none" );
cmd( ".ini.b.tx conf -cursor arrow" );
strncpy( ch1, obj_name, MAX_ELEM_LENGTH - 1 );
ch1[ MAX_ELEM_LENGTH - 1 ] = '\0';
cmd( "label $w.tit_empty -width 32 -relief raised -text \"Object: %-17s \" -borderwidth 4", ch1 );
cmd( "bind $w.tit_empty <Button-1> {set choice 4}" );
if ( ! in_set_obj ) // show only if not already recursing
cmd( "bind $w.tit_empty <Enter> {set msg \"Click to edit number of instances\"}" );
cmd( "bind $w.tit_empty <Leave> {set msg \"\"}" );
cmd( "$w window create end -window $w.tit_empty" );
strcpy( ch, "" );
i = 0;
counter = 1;
colOvflw = false;
search_title( root, ch, &i, obj_name, &counter );
cmd( "$w insert end \\n" );
// explore the tree searching for each instance of such object and create:
// - titles
// - entry cells linked to the values
set_focus = 0;
link_data( root, obj_name );
cmd( "pack .ini.b.ys -side right -fill y" );
cmd( "pack .ini.b.xs -side bottom -fill x" );
cmd( "pack .ini.b.tx -expand yes -fill both" );
cmd( "pack .ini.b -expand yes -fill both" );
cmd( "label .ini.msg -textvariable msg" );
cmd( "pack .ini.msg -pady 5" );
cmd( "frame .ini.st" );
cmd( "label .ini.st.err -text \"\"" );
cmd( "label .ini.st.pad -text \" \"" );
cmd( "checkbutton .ini.st.aw -text \"Automatic width\" -variable autoWidth -command { set choice 5 }" );
cmd( "pack .ini.st.err .ini.st.pad .ini.st.aw -side left" );
cmd( "pack .ini.st -anchor e -padx 10 -pady 5" );
cmd( "donehelp .ini boh { set choice 1 } { LsdHelp menudata_init.html }" );
cmd( "$w configure -state disabled" );
if ( set_focus == 1 )
cmd( "focus $initial_focus; $initial_focus selection range 0 end" );
cmd( "bind .ini <KeyPress-Escape> {set choice 1}" );
cmd( "bind .ini <F1> { LsdHelp menudata_init.html }" );
// show overflow warning just once per configuration but always indicate
if ( colOvflw )
{
cmd( ".ini.st.err conf -text \"OBJECTS NOT SHOWN! (> %d)\" -fg red", MAX_COLS );
if ( ! iniShowOnce )
{
cmd( "update; tk_messageBox -parent .ini -type ok -title Warning -icon warning -message \"Too many objects to edit\" -detail \"LSD Initial Values editor can show only the first %d objects' values. Please use the 'Set All' button to define values for objects beyond those.\" ", MAX_COLS );
iniShowOnce = true;
}
}
noredraw:
cmd( "if $autoWidth { resizetop .ini [ expr ( 40 + %d * ( $cwidth + 1 ) ) * [ font measure TkTextFont -displayof .ini 0 ] ] }", counter );
// editor main command loop
while ( ! *choice )
{
try
{
Tcl_DoOneEvent( 0 );
}
catch ( bad_alloc& ) // raise memory problems
{
throw;
}
catch ( ... ) // ignore the rest
{
goto noredraw;
}
}
// handle both resizing event and block object # setting while editing initial values
if ( *choice == 5 || ( *choice == 4 && in_set_obj ) ) // avoid recursion
{
*choice = 0;
goto noredraw;
}
// clean up
strcpy( ch, "" );
i = 0;
clean_cell( root, ch, obj_name );
cmd( "destroy .ini.b .ini.boh .ini.msg .ini.st" );
if ( *choice == 2 )
{
l = ( char * ) Tcl_GetVar( inter, "var-S-A", 0 );
strcpy( ch, l );
*choice = 2; // set data editor window parent
set_all( choice, first, ch, lag );
cmd( "bind .ini <KeyPress-Return> {}" );
*choice = 0;
}
if ( *choice ==4 )
{
*choice = 0;
set_obj_number( root, choice );
*choice = 0;
}
}
in_edit_data = false;
Tcl_UnlinkVar( inter, "lag");
}