/* This function is used instead of the snack_sndfile_ext.tcl script in order
to generate the tcl variables that are needed by snack. Doing it here allows
keeping the formats always up to date with the current version of libsndfile
*/
int CreateTclVariablesForSnack(Tcl_Interp *interp)
{
int k, count ;
SF_FORMAT_INFO format_info ;
Tcl_Obj *scriptPtr = Tcl_NewStringObj("", 0);
Tcl_Obj *scriptPtr1 = Tcl_NewStringObj("", 0);
Tcl_Obj *scriptPtr2 = Tcl_NewStringObj("", 0);
Tcl_Obj *formatExtUC = Tcl_NewStringObj("", 0);
Tcl_AppendStringsToObj(scriptPtr,
"namespace eval snack::snack_sndfile_ext {\n",
" variable extTypes\n",
" variable loadTypes\n",
" variable loadKeys\n\n", (char *) NULL);
Tcl_AppendStringsToObj(scriptPtr1, " set extTypesMC {\n", (char *) NULL);
Tcl_AppendStringsToObj(scriptPtr2, " set loadTypes {\n", (char *) NULL);
sf_command (NULL, SFC_GET_FORMAT_MAJOR_COUNT, &count, sizeof (int));
for (k = 0 ; k < count ; k++) {
format_info.format = k ;
sf_command (NULL, SFC_GET_FORMAT_MAJOR, &format_info, sizeof (SF_FORMAT_INFO));
/* convert extension to upper case */
Tcl_SetStringObj(formatExtUC, format_info.extension, strlen(format_info.extension));
Tcl_UtfToUpper(Tcl_GetString(formatExtUC));
/* append to variable extTypesMC */
Tcl_AppendStringsToObj(scriptPtr1, " {{", format_info.name,
"} .", format_info.extension, "}\n", (char *) NULL);
/* append to variable loadTypes */
Tcl_AppendStringsToObj(scriptPtr2, " {{", format_info.name,
"} {.", format_info.extension,
" .", Tcl_GetString(formatExtUC),
"}}\n", (char *) NULL);
}
Tcl_AppendStringsToObj(scriptPtr1, " }\n\n", (char *) NULL);
Tcl_AppendStringsToObj(scriptPtr2, " }\n\n", (char *) NULL);
Tcl_AppendObjToObj(scriptPtr, scriptPtr1);
Tcl_AppendObjToObj(scriptPtr, scriptPtr2);
Tcl_AppendStringsToObj(scriptPtr,
" set extTypes [list]\n",
" set loadKeys [list]\n",
" foreach pair $extTypesMC {\n",
" set type [string toupper [lindex $pair 0]]\n",
" set ext [lindex $pair 1]\n",
" lappend extTypes [list $type $ext]\n",
" lappend loadKeys $type\n"
" }\n\n",
" snack::addLoadTypes $loadTypes $loadKeys\n",
" snack::addExtTypes $extTypes\n",
"}\n", (char *) NULL);
/* fprintf(stderr, "%s\n", Tcl_GetString(scriptPtr)); */
return Tcl_EvalObjEx(interp, scriptPtr, TCL_EVAL_DIRECT);
}
/**
\brief Speical function to obtain the text assigned to the button widget.
**/
Tcl_Obj *gnoclCgetButtonText ( Tcl_Interp *interp, GtkButton *button )
{
Tcl_Obj *obj = NULL;
if ( gtk_button_get_use_stock ( button ) )
{
const char *st = gtk_button_get_label ( button );
if ( st == NULL )
{
obj = Tcl_NewStringObj ( "", 0 );
}
else
{
obj = Tcl_NewStringObj ( "%#", 2 );
Tcl_AppendObjToObj ( obj, gnoclGtkToStockName ( st ) );
}
}
else
{
GtkLabel *label = GTK_LABEL ( gnoclFindChild ( GTK_WIDGET ( button ), GTK_TYPE_LABEL ) );
Tcl_Obj *old = Tcl_NewStringObj ( gtk_label_get_label ( label ), -1 );
assert ( label );
if ( gtk_label_get_use_markup ( label ) )
{
obj = Tcl_NewStringObj ( "%<", 2 );
Tcl_AppendObjToObj ( obj, old );
}
else if ( gtk_label_get_use_underline ( label ) )
{
obj = Tcl_NewStringObj ( "%_", 2 );
Tcl_AppendObjToObj ( obj, old );
}
else
{
obj = old;
}
}
return obj;
}
/**
\brief Obtain current -option values.
**/
static int cget ( Tcl_Interp *interp, GtkButton *button, GnoclOption options[], int idx )
{
Tcl_Obj *obj = NULL;
if ( idx == textIdx )
{
obj = gnoclCgetButtonText ( interp, button );
}
else if ( idx == iconIdx )
{
GtkWidget *image = gnoclFindChild ( GTK_WIDGET ( button ), GTK_TYPE_IMAGE );
if ( image == NULL )
{
obj = Tcl_NewStringObj ( "", 0 );
}
else
{
gchar *st;
g_object_get ( G_OBJECT ( image ), "stock", &st, NULL );
if ( st )
{
obj = Tcl_NewStringObj ( "%#", 2 );
Tcl_AppendObjToObj ( obj, gnoclGtkToStockName ( st ) );
g_free ( st );
}
else
{
Tcl_SetResult ( interp, "Could not determine icon type.", TCL_STATIC );
return TCL_ERROR;
}
}
}
if ( obj != NULL )
{
Tcl_SetObjResult ( interp, obj );
return TCL_OK;
}
return gnoclCgetNotImplemented ( interp, options + idx );
}
/*
** This is the callback from a quota-over-limit.
*/
static void tclQuotaCallback(
const char *zFilename, /* Name of file whose size increases */
sqlite3_int64 *piLimit, /* IN/OUT: The current limit */
sqlite3_int64 iSize, /* Total size of all files in the group */
void *pArg /* Client data */
){
TclQuotaCallback *p; /* Callback script object */
Tcl_Obj *pEval; /* Script to evaluate */
Tcl_Obj *pVarname; /* Name of variable to pass as 2nd arg */
unsigned int rnd; /* Random part of pVarname */
int rc; /* Tcl error code */
p = (TclQuotaCallback *)pArg;
if( p==0 ) return;
pVarname = Tcl_NewStringObj("::piLimit_", -1);
Tcl_IncrRefCount(pVarname);
sqlite3_randomness(sizeof(rnd), (void *)&rnd);
Tcl_AppendObjToObj(pVarname, Tcl_NewIntObj((int)(rnd&0x7FFFFFFF)));
Tcl_ObjSetVar2(p->interp, pVarname, 0, Tcl_NewWideIntObj(*piLimit), 0);
pEval = Tcl_DuplicateObj(p->pScript);
Tcl_IncrRefCount(pEval);
Tcl_ListObjAppendElement(0, pEval, Tcl_NewStringObj(zFilename, -1));
Tcl_ListObjAppendElement(0, pEval, pVarname);
Tcl_ListObjAppendElement(0, pEval, Tcl_NewWideIntObj(iSize));
rc = Tcl_EvalObjEx(p->interp, pEval, TCL_EVAL_GLOBAL);
if( rc==TCL_OK ){
Tcl_Obj *pLimit = Tcl_ObjGetVar2(p->interp, pVarname, 0, 0);
rc = Tcl_GetWideIntFromObj(p->interp, pLimit, piLimit);
Tcl_UnsetVar(p->interp, Tcl_GetString(pVarname), 0);
}
Tcl_DecrRefCount(pEval);
Tcl_DecrRefCount(pVarname);
if( rc!=TCL_OK ) Tcl_BackgroundError(p->interp);
}
int
diff_objs(Tcl_Interp *interp, const char *db1, const char *db2)
{
struct directory *dp1, *dp2;
char *argv[4] = {NULL, NULL, NULL, NULL};
struct bu_vls s1_tcl = BU_VLS_INIT_ZERO;
struct bu_vls s2_tcl = BU_VLS_INIT_ZERO;
struct bu_vls vls = BU_VLS_INIT_ZERO;
int has_diff = 0;
/* look at all objects in this database */
FOR_ALL_DIRECTORY_START(dp1, dbip1) {
char *str1, *str2;
Tcl_Obj *obj1, *obj2;
/* check if this object exists in the other database */
if ((dp2 = db_lookup(dbip2, dp1->d_namep, 0)) == RT_DIR_NULL) {
kill_obj(dp1->d_namep);
continue;
}
/* skip the _GLOBAL object */
if (dp1->d_major_type == DB5_MAJORTYPE_ATTRIBUTE_ONLY)
continue;
/* try to get the TCL version of this object */
bu_vls_trunc(&vls, 0);
bu_vls_printf(&vls, "%s get %s", db1, dp1->d_namep);
if (Tcl_Eval(interp, bu_vls_addr(&vls)) != TCL_OK) {
/* cannot get TCL version, use bu_external */
Tcl_ResetResult(interp);
has_diff += compare_external(dp1, dp2);
continue;
}
obj1 = Tcl_NewListObj(0, NULL);
Tcl_AppendObjToObj(obj1, Tcl_GetObjResult(interp));
bu_vls_trunc(&s1_tcl, 0);
bu_vls_trunc(&s2_tcl, 0);
bu_vls_strcpy(&s1_tcl, Tcl_GetStringResult(interp));
str1 = bu_vls_addr(&s1_tcl);
Tcl_ResetResult(interp);
/* try to get TCL version of object from the other database */
bu_vls_trunc(&vls, 0);
bu_vls_printf(&vls, "%s get %s", db2, dp1->d_namep);
if (Tcl_Eval(interp, bu_vls_addr(&vls)) != TCL_OK) {
Tcl_ResetResult(interp);
/* cannot get it, they MUST be different */
if (mode == HUMAN)
printf("Replace %s with the same object from %s\n",
dp1->d_namep, dbip2->dbi_filename);
else
printf("kill %s\n# IMPORT %s from %s\n",
dp1->d_namep, dp2->d_namep, dbip2->dbi_filename);
continue;
}
obj2 = Tcl_NewListObj(0, NULL);
Tcl_AppendObjToObj(obj2, Tcl_GetObjResult(interp));
bu_vls_strcpy(&s2_tcl, Tcl_GetStringResult(interp));
str2 = bu_vls_addr(&s2_tcl);
Tcl_ResetResult(interp);
/* got TCL versions of both */
if ((dp1->d_flags & RT_DIR_SOLID) && (dp2->d_flags & RT_DIR_SOLID)) {
/* both are solids */
has_diff += compare_tcl_solids(str1, obj1, dp1, str2, obj2);
if (pre_5_vers != 2) {
has_diff += compare_attrs(dp1, dp2);
}
continue;
}
if ((dp1->d_flags & RT_DIR_COMB) && (dp2->d_flags & RT_DIR_COMB)) {
/* both are combinations */
has_diff += compare_tcl_combs(obj1, dp1, obj2);
if (pre_5_vers != 2) {
has_diff += compare_attrs(dp1, dp2);
}
continue;
}
/* the two objects are different types */
if (!BU_STR_EQUAL(str1, str2)) {
has_diff += 1;
if (mode == HUMAN)
printf("%s:\n\twas: %s\n\tis now: %s\n\n",
dp1->d_namep, str1, str2);
else
printf("kill %s\ndb put %s %s\n",
dp1->d_namep, dp2->d_namep, str2);
}
} FOR_ALL_DIRECTORY_END;
/* ARGSUSED */
int
Tcl_ExecObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
/*
* This function generates an argv array for the string arguments. It
* starts out with stack-allocated space but uses dynamically-allocated
* storage if needed.
*/
Tcl_Obj *resultPtr;
const char **argv;
char *string;
Tcl_Channel chan;
int argc, background, i, index, keepNewline, result, skip, length;
int ignoreStderr;
static const char *options[] = {
"-ignorestderr", "-keepnewline", "--", NULL
};
enum options {
EXEC_IGNORESTDERR, EXEC_KEEPNEWLINE, EXEC_LAST
};
/*
* Check for any leading option arguments.
*/
keepNewline = 0;
ignoreStderr = 0;
for (skip = 1; skip < objc; skip++) {
string = TclGetString(objv[skip]);
if (string[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[skip], options, "switch",
TCL_EXACT, &index) != TCL_OK) {
return TCL_ERROR;
}
if (index == EXEC_KEEPNEWLINE) {
keepNewline = 1;
} else if (index == EXEC_IGNORESTDERR) {
ignoreStderr = 1;
} else {
skip++;
break;
}
}
if (objc <= skip) {
Tcl_WrongNumArgs(interp, 1, objv, "?switches? arg ?arg ...?");
return TCL_ERROR;
}
/*
* See if the command is to be run in background.
*/
background = 0;
string = TclGetString(objv[objc - 1]);
if ((string[0] == '&') && (string[1] == '\0')) {
objc--;
background = 1;
}
/*
* Create the string argument array "argv". Make sure argv is large enough
* to hold the argc arguments plus 1 extra for the zero end-of-argv word.
*/
argc = objc - skip;
argv = (const char **)
TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *));
/*
* Copy the string conversions of each (post option) object into the
* argument vector.
*/
for (i = 0; i < argc; i++) {
argv[i] = TclGetString(objv[i + skip]);
}
argv[argc] = NULL;
chan = Tcl_OpenCommandChannel(interp, argc, argv, (background ? 0 :
(ignoreStderr ? TCL_STDOUT : TCL_STDOUT|TCL_STDERR)));
/*
* Free the argv array.
*/
TclStackFree(interp, (void *)argv);
if (chan == NULL) {
return TCL_ERROR;
}
if (background) {
/*
* Store the list of PIDs from the pipeline in interp's result and
* detach the PIDs (instead of waiting for them).
*/
TclGetAndDetachPids(interp, chan);
if (Tcl_Close(interp, chan) != TCL_OK) {
return TCL_ERROR;
}
return TCL_OK;
}
resultPtr = Tcl_NewObj();
if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) {
if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) {
/*
* TIP #219.
* Capture error messages put by the driver into the bypass area
* and put them into the regular interpreter result. Fall back to
* the regular message if nothing was found in the bypass.
*/
if (!TclChanCaughtErrorBypass(interp, chan)) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "error reading output from command: ",
Tcl_PosixError(interp), NULL);
Tcl_DecrRefCount(resultPtr);
}
return TCL_ERROR;
}
}
/*
* If the process produced anything on stderr, it will have been returned
* in the interpreter result. It needs to be appended to the result
* string.
*/
result = Tcl_Close(interp, chan);
Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp));
/*
* If the last character of the result is a newline, then remove the
* newline character.
*/
if (keepNewline == 0) {
string = TclGetStringFromObj(resultPtr, &length);
if ((length > 0) && (string[length - 1] == '\n')) {
Tcl_SetObjLength(resultPtr, length - 1);
}
}
Tcl_SetObjResult(interp, resultPtr);
return result;
}
/* Process the nucleic acid codes by substituting each nucleic acid
* code in "s" with its meaning as defined in the static "nacodes"
* structure (see top of file). On return, "s" will hold the
* substituted string. */
static void
process_nacodes(int cpu_count,
Tcl_Obj* s)
{
int i = 0;
int first = 0;
int last = 0;
int s_length = 0;
int range_length = 0;
int thread_rv = 0;
nacodes_worker_data_t data = NULL;
pthread_t* threads = NULL;
/* Sanity check to make sure we don't divide by zero. */
if (cpu_count == 0) {
return;
}
/* Get the total length of s. */
s_length = Tcl_GetCharLength(s);
if (s_length == 0) {
return;
}
/* Allocate the "data" array which is used to pass data to and
* from the threads. */
data = calloc(cpu_count, sizeof(*data));
/* Allocate the "threads" array which holds the thread IDs. */
threads = calloc(cpu_count, sizeof(*threads));
/* Calculate the number of characters to feed each thread. Note
* that we checked above to make sure cpu_count is not zero. */
range_length = s_length / cpu_count;
/* Start one thread for each cpu. */
for (i = 0 ; i < cpu_count ; ++i) {
/* First, initialize the thread's client data. */
/* Calculate the first and last index for the range. Both
* "first" and "last" indexes are inclusive because that is
* what Tcl_GetRange() requires. We also need to make sure
* the very last range has all the characters in case
* range_length does not divide s_length evenly. */
first = range_length * i;
last = range_length * (i + 1) - 1;
if (i + 1 == cpu_count) {
last = s_length - 1;
}
/* Pack the data for the worker thread. */
data[i].range = Tcl_GetRange(s, first, last);
Tcl_IncrRefCount(data[i].range);
/* Second, start the thread. */
thread_rv = pthread_create(&threads[i],
NULL,
(thread_start_t)process_nacodes_worker,
&data[i]);
if (thread_rv) {
fprintf(stderr, "*** Error: pthread_create: failed");
exit(1);
}
}
/* Wait for each thread to finish. */
for (i = 0 ; i < cpu_count ; ++i) {
thread_rv = pthread_join(threads[i], NULL);
if (thread_rv) {
fprintf(stderr, "*** Error: pthread_join: failed");
exit(1);
}
}
/* Merge results. */
Tcl_SetObjLength(s, 0);
for (i = 0 ; i < cpu_count ; ++i) {
Tcl_AppendObjToObj(s, data[i].range);
}
/* Clean up. */
for (i = 0 ; i < cpu_count ; ++i) {
Tcl_DecrRefCount(data[i].range);
}
free(threads);
free(data);
}
static int
RectOvalToPostscript(
Tcl_Interp *interp, /* Interpreter for error reporting. */
Tk_Canvas canvas, /* Information about overall canvas. */
Tk_Item *itemPtr, /* Item for which Postscript is wanted. */
int prepass) /* 1 means this is a prepass to collect font
* information; 0 means final Postscript is
* being created. */
{
Tcl_Obj *pathObj, *psObj;
RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr;
double y1, y2;
XColor *color;
XColor *fillColor;
Pixmap fillStipple;
Tk_State state = itemPtr->state;
Tcl_InterpState interpState;
y1 = Tk_CanvasPsY(canvas, rectOvalPtr->bbox[1]);
y2 = Tk_CanvasPsY(canvas, rectOvalPtr->bbox[3]);
/*
* Generate a string that creates a path for the rectangle or oval. This
* is the only part of the function's code that is type-specific.
*/
if (rectOvalPtr->header.typePtr == &tkRectangleType) {
pathObj = Tcl_ObjPrintf(
"%.15g %.15g moveto "
"%.15g 0 rlineto "
"0 %.15g rlineto "
"%.15g 0 rlineto "
"closepath\n",
rectOvalPtr->bbox[0], y1,
rectOvalPtr->bbox[2]-rectOvalPtr->bbox[0],
y2-y1,
rectOvalPtr->bbox[0]-rectOvalPtr->bbox[2]);
} else {
pathObj = Tcl_ObjPrintf(
"matrix currentmatrix\n"
"%.15g %.15g translate "
"%.15g %.15g scale "
"1 0 moveto 0 0 1 0 360 arc\n"
"setmatrix\n",
(rectOvalPtr->bbox[0] + rectOvalPtr->bbox[2])/2, (y1 + y2)/2,
(rectOvalPtr->bbox[2] - rectOvalPtr->bbox[0])/2, (y1 - y2)/2);
}
if (state == TK_STATE_NULL) {
state = Canvas(canvas)->canvas_state;
}
color = rectOvalPtr->outline.color;
fillColor = rectOvalPtr->fillColor;
fillStipple = rectOvalPtr->fillStipple;
if (Canvas(canvas)->currentItemPtr == itemPtr) {
if (rectOvalPtr->outline.activeColor!=NULL) {
color = rectOvalPtr->outline.activeColor;
}
if (rectOvalPtr->activeFillColor!=NULL) {
fillColor = rectOvalPtr->activeFillColor;
}
if (rectOvalPtr->activeFillStipple!=None) {
fillStipple = rectOvalPtr->activeFillStipple;
}
} else if (state == TK_STATE_DISABLED) {
if (rectOvalPtr->outline.disabledColor!=NULL) {
color = rectOvalPtr->outline.disabledColor;
}
if (rectOvalPtr->disabledFillColor!=NULL) {
fillColor = rectOvalPtr->disabledFillColor;
}
if (rectOvalPtr->disabledFillStipple!=None) {
fillStipple = rectOvalPtr->disabledFillStipple;
}
}
/*
* Make our working space.
*/
psObj = Tcl_NewObj();
interpState = Tcl_SaveInterpState(interp, TCL_OK);
/*
* First draw the filled area of the rectangle.
*/
if (fillColor != NULL) {
Tcl_AppendObjToObj(psObj, pathObj);
Tcl_ResetResult(interp);
if (Tk_CanvasPsColor(interp, canvas, fillColor) != TCL_OK) {
goto error;
}
Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp));
if (fillStipple != None) {
Tcl_AppendToObj(psObj, "clip ", -1);
Tcl_ResetResult(interp);
if (Tk_CanvasPsStipple(interp, canvas, fillStipple) != TCL_OK) {
goto error;
}
Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp));
if (color != NULL) {
Tcl_AppendToObj(psObj, "grestore gsave\n", -1);
}
} else {
Tcl_AppendToObj(psObj, "fill\n", -1);
}
}
/*
* Now draw the outline, if there is one.
*/
if (color != NULL) {
Tcl_AppendObjToObj(psObj, pathObj);
Tcl_AppendToObj(psObj, "0 setlinejoin 2 setlinecap\n", -1);
Tcl_ResetResult(interp);
if (Tk_CanvasPsOutline(canvas, itemPtr,
&rectOvalPtr->outline)!= TCL_OK) {
goto error;
}
Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp));
}
/*
* Plug the accumulated postscript back into the result.
*/
(void) Tcl_RestoreInterpState(interp, interpState);
Tcl_AppendObjToObj(Tcl_GetObjResult(interp), psObj);
Tcl_DecrRefCount(psObj);
Tcl_DecrRefCount(pathObj);
return TCL_OK;
error:
Tcl_DiscardInterpState(interpState);
Tcl_DecrRefCount(psObj);
Tcl_DecrRefCount(pathObj);
return TCL_ERROR;
}
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, *LObj;
int commandLen;
char *commandStr;
const char *encodingName = NULL;
int code, exitCode = 0, isL = 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 initial args (argv[1] and beyond) look like
* -encoding ENCODING FILENAME
* or like
* [-opt1] [-opt2] ... [-optn] FILENAME
*/
/* Create argv list obj for L. */
L->global->tclsh_argc = 1;
L->global->tclsh_argv = Tcl_NewObj();
Tcl_ListObjAppendElement(NULL, L->global->tclsh_argv,
NewNativeObj(argv[0], -1));
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) {
/* Pass over all options to look for a file name. */
int i;
Tcl_Obj *argObj;
for (i = 1; i < argc; ++i) {
argObj = NewNativeObj(argv[i], -1);
Tcl_ListObjAppendElement(NULL, L->global->tclsh_argv, argObj);
++L->global->tclsh_argc;
if ('-' != argv[i][0]) {
Tcl_SetStartupScript(argObj, NULL);
argc -= i;
argv += i;
break;
} else if (!_tcscmp(argv[i], TEXT("--version")) ||
!_tcscmp(argv[i], TEXT("-version"))) {
if (strlen(L_VER_TAG)) {
printf("L version is %s %s for %s\n",
L_VER_TAG, L_VER_UTC, L_VER_PLATFORM);
} else {
printf("L version is %s for %s\n",
L_VER_UTC, L_VER_PLATFORM);
}
printf("Built by: %s\n", L_VER_USER);
printf("Built in: %s\n", L_VER_PWD);
printf("Built on: %s\n", L_VER_BUILD_TIME);
exit(0);
}
}
}
}
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);
L->global->script_argc = argc;
argvPtr = Tcl_NewListObj(0, NULL);
while (argc--) {
Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1));
}
Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
L->global->script_argv = argvPtr;
Tcl_IncrRefCount(argvPtr);
/*
* 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) {
int argc, i;
char *av0path;
Tcl_Obj **argvObjs, *pathObj;
/*
* Set L->global->forceL if argv[0] is "L", or "-L" or "--L" was given
* as a cmd-line option. This causes Tcl_FSEvalFileEx() to wrap the
* input file in a #lang L regardless of its extension.
*/
if (L->global->tclsh_argv) {
Tcl_ListObjGetElements(interp, L->global->tclsh_argv, &argc,
&argvObjs);
pathObj = Tcl_FSGetNormalizedPath(interp, argvObjs[0]);
av0path = Tcl_GetString(pathObj);
if (av0path) {
L->global->forceL = (!strcmp(av0path+strlen(av0path)-2, "/L"));
}
for (i = 1; i < argc; ++i) {
if (!strcmp(Tcl_GetString(argvObjs[i]), "--L") ||
!strcmp(Tcl_GetString(argvObjs[i]), "-L")) {
L->global->forceL = 1;
}
}
}
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, "L", (char *) &isL, TCL_LINK_BOOLEAN);
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;
}
/*
* Check for the #lang comments and sub them out for
* meaningful commands.
*/
commandStr = Tcl_GetStringFromObj(is.commandPtr, &commandLen);
if (!isL && strncasecmp(commandStr, "#lang l", 7) == 0) {
Tcl_SetStringObj(is.commandPtr, "set ::L 1", -1);
} else if (isL && strncasecmp(commandStr, "#lang tcl", 9) == 0) {
Tcl_SetStringObj(is.commandPtr, "set('::L',0);", -1);
}
/*
* 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;
if (isL) {
LObj = Tcl_NewStringObj("L {", -1);
Tcl_AppendObjToObj(LObj, is.commandPtr);
if (commandStr[commandLen-1] != ';') {
Tcl_AppendToObj(LObj, ";", -1);
}
Tcl_AppendToObj(LObj, "}\n", -1);
Tcl_DecrRefCount(is.commandPtr);
is.commandPtr = LObj;
Tcl_IncrRefCount(is.commandPtr);
}
/*
* 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
CanvasPsWindow(
Tcl_Interp *interp, /* Leave Postscript or error message here. */
Tk_Window tkwin, /* window to be printed */
Tk_Canvas canvas, /* Information about overall canvas. */
double x, double y, /* origin of window. */
int width, int height) /* width/height of window. */
{
XImage *ximage;
int result;
#ifdef X_GetImage
Tk_ErrorHandler handle;
#endif
Tcl_Obj *cmdObj, *psObj;
Tcl_InterpState interpState = Tcl_SaveInterpState(interp, TCL_OK);
/*
* Locate the subwindow within the wider window.
*/
psObj = Tcl_ObjPrintf(
"\n%%%% %s item (%s, %d x %d)\n" /* Comment */
"%.15g %.15g translate\n", /* Position */
Tk_Class(tkwin), Tk_PathName(tkwin), width, height, x, y);
/*
* First try if the widget has its own "postscript" command. If it exists,
* this will produce much better postscript than when a pixmap is used.
*/
Tcl_ResetResult(interp);
cmdObj = Tcl_ObjPrintf("%s postscript -prolog 0", Tk_PathName(tkwin));
Tcl_IncrRefCount(cmdObj);
result = Tcl_EvalObjEx(interp, cmdObj, 0);
Tcl_DecrRefCount(cmdObj);
if (result == TCL_OK) {
Tcl_AppendPrintfToObj(psObj,
"50 dict begin\nsave\ngsave\n"
"0 %d moveto %d 0 rlineto 0 -%d rlineto -%d 0 rlineto closepath\n"
"1.000 1.000 1.000 setrgbcolor AdjustColor\nfill\ngrestore\n",
height, width, height, width);
Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp));
Tcl_AppendToObj(psObj, "\nrestore\nend\n\n\n", -1);
goto done;
}
/*
* If the window is off the screen it will generate a BadMatch/XError. We
* catch any BadMatch errors here
*/
#ifdef X_GetImage
handle = Tk_CreateErrorHandler(Tk_Display(tkwin), BadMatch,
X_GetImage, -1, xerrorhandler, tkwin);
#endif
/*
* Generate an XImage from the window. We can then read pixel values out
* of the XImage.
*/
ximage = XGetImage(Tk_Display(tkwin), Tk_WindowId(tkwin), 0, 0,
(unsigned) width, (unsigned) height, AllPlanes, ZPixmap);
#ifdef X_GetImage
Tk_DeleteErrorHandler(handle);
#endif
if (ximage == NULL) {
result = TCL_OK;
} else {
Tcl_ResetResult(interp);
result = TkPostscriptImage(interp, tkwin, Canvas(canvas)->psInfo,
ximage, 0, 0, width, height);
Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp));
XDestroyImage(ximage);
}
/*
* Plug the accumulated postscript back into the result.
*/
done:
if (result == TCL_OK) {
(void) Tcl_RestoreInterpState(interp, interpState);
Tcl_AppendObjToObj(Tcl_GetObjResult(interp), psObj);
} else {
Tcl_DiscardInterpState(interpState);
}
Tcl_DecrRefCount(psObj);
return result;
}
/*
* putchan_raw <server_tag> <#chan> <text>
* Use this instead of putserv so that can see own message
*
* "raw" because putchan in Tcl will do some string fixing on text
*
* all command parameters should be using unicode (internal) encoding.
*/
int
putchan_raw(ClientData clientData, Tcl_Interp* interp, int objc,
Tcl_Obj* const objv[])
{
(void) clientData;
if (objc != 4) {
Tcl_Obj* str = Tcl_ObjPrintf("wrong # args: should be \"putchan_raw"
" server_tag channel text\"");
Tcl_SetObjResult(interp, str);
return TCL_ERROR;
}
Tcl_Obj* const server_tag = objv[1];
Tcl_Obj* const target = objv[2];
Tcl_Obj* const msg = objv[3];
// find the server in Irssi.
SERVER_REC* server_rec = server_find_tag(Tcl_GetString(server_tag));
if (server_rec == NULL) {
Tcl_Obj* str = Tcl_ObjPrintf("server with tag '%s' not found",
Tcl_GetString(server_tag));
Tcl_SetObjResult(interp, str);
return TCL_ERROR;
}
// find the channel on this server in Irssi.
CHANNEL_REC* channel_rec = channel_find(server_rec, Tcl_GetString(target));
if (channel_rec == NULL) {
Tcl_Obj* str = Tcl_ObjPrintf("channel '%s' not found on server '%s'",
Tcl_GetString(target), Tcl_GetString(server_tag));
Tcl_SetObjResult(interp, str);
return TCL_ERROR;
}
// create the full command string to send to the IRC server.
// PRIVMSG <target> :<msg>
// this is how we used to create the command but I am concerned it
// is not dealing with encoding correctly.
//Tcl_Obj* send_str = Tcl_ObjPrintf("PRIVMSG %s :%s", target, msg);
// try to be more careful with how we build the string.
// -1 means take everything up to first NULL.
Tcl_Obj* send_str = Tcl_NewStringObj("PRIVMSG ", -1);
if (!send_str) {
return TCL_ERROR;
}
Tcl_AppendObjToObj(send_str, target);
Tcl_AppendToObj(send_str, " :", strlen(" :"));
Tcl_AppendObjToObj(send_str, msg);
// send the command to the server.
// from ByteArrObj docs:
// "Obtaining the string representation of a byte-array object (by calling Tcl_GetStringFromObj) produces a properly formed UTF-8 sequence with a one-to-one mapping between the bytes in the internal representation and the UTF-8 characters in the string representation."
irc_send_cmd((IRC_SERVER_REC*) server_rec, Tcl_GetString(send_str));
// this frees the object. unsure if I actually need to call this, but it
// seems like it doesn't matter if I do!
Tcl_DecrRefCount(send_str);
// write the message to Irssi so we see it ourselves.
print_message_public(server_rec, channel_rec, Tcl_GetString(target),
server_rec->nick, NULL, Tcl_GetString(msg));
//signal_emit("message own_public", 3, server, text, chan);
return TCL_OK;
}
void
TkMakeRawCurvePostscript(
Tcl_Interp *interp, /* Interpreter in whose result the Postscript
* is to be stored. */
Tk_Canvas canvas, /* Canvas widget for which the Postscript is
* being generated. */
double *pointPtr, /* Array of input coordinates: x0, y0, x1, y1,
* etc.. */
int numPoints) /* Number of points at pointPtr. */
{
int i;
double *segPtr;
Tcl_Obj *psObj;
/*
* Put the first point into the path.
*/
psObj = Tcl_ObjPrintf("%.15g %.15g moveto\n",
pointPtr[0], Tk_CanvasPsY(canvas, pointPtr[1]));
/*
* Loop through all the remaining points in the curve, generating a
* straight line or curve section for every three of them.
*/
for (i=numPoints-1,segPtr=pointPtr ; i>=3 ; i-=3,segPtr+=6) {
if (segPtr[0]==segPtr[2] && segPtr[1]==segPtr[3] &&
segPtr[4]==segPtr[6] && segPtr[5]==segPtr[7]) {
/*
* The control points on this segment are equal to their
* neighbouring knots, so this segment is just a straight line.
*/
Tcl_AppendPrintfToObj(psObj, "%.15g %.15g lineto\n",
segPtr[6], Tk_CanvasPsY(canvas, segPtr[7]));
} else {
/*
* This is a generic Bezier curve segment.
*/
Tcl_AppendPrintfToObj(psObj,
"%.15g %.15g %.15g %.15g %.15g %.15g curveto\n",
segPtr[2], Tk_CanvasPsY(canvas, segPtr[3]),
segPtr[4], Tk_CanvasPsY(canvas, segPtr[5]),
segPtr[6], Tk_CanvasPsY(canvas, segPtr[7]));
}
}
/*
* If there are any points left that haven't been used, then build the
* last segment and generate Postscript in the same way for that.
*/
if (i > 0) {
int j;
double control[8];
for (j=0; j<2*i+2; j++) {
control[j] = segPtr[j];
}
for (; j<8; j++) {
control[j] = pointPtr[j-2*i-2];
}
if (control[0]==control[2] && control[1]==control[3] &&
control[4]==control[6] && control[5]==control[7]) {
/*
* Straight line.
*/
Tcl_AppendPrintfToObj(psObj, "%.15g %.15g lineto\n",
control[6], Tk_CanvasPsY(canvas, control[7]));
} else {
/*
* Bezier curve segment.
*/
Tcl_AppendPrintfToObj(psObj,
"%.15g %.15g %.15g %.15g %.15g %.15g curveto\n",
control[2], Tk_CanvasPsY(canvas, control[3]),
control[4], Tk_CanvasPsY(canvas, control[5]),
control[6], Tk_CanvasPsY(canvas, control[7]));
}
}
Tcl_AppendObjToObj(Tcl_GetObjResult(interp), psObj);
Tcl_DecrRefCount(psObj);
}
void
TkMakeBezierPostscript(
Tcl_Interp *interp, /* Interpreter in whose result the Postscript
* is to be stored. */
Tk_Canvas canvas, /* Canvas widget for which the Postscript is
* being generated. */
double *pointPtr, /* Array of input coordinates: x0, y0, x1, y1,
* etc.. */
int numPoints) /* Number of points at pointPtr. */
{
int closed, i;
int numCoords = numPoints*2;
double control[8];
Tcl_Obj *psObj;
/*
* If the curve is a closed one then generate a special spline that spans
* the last points and the first ones. Otherwise just put the first point
* into the path.
*/
if ((pointPtr[0] == pointPtr[numCoords-2])
&& (pointPtr[1] == pointPtr[numCoords-1])) {
closed = 1;
control[0] = 0.5*pointPtr[numCoords-4] + 0.5*pointPtr[0];
control[1] = 0.5*pointPtr[numCoords-3] + 0.5*pointPtr[1];
control[2] = 0.167*pointPtr[numCoords-4] + 0.833*pointPtr[0];
control[3] = 0.167*pointPtr[numCoords-3] + 0.833*pointPtr[1];
control[4] = 0.833*pointPtr[0] + 0.167*pointPtr[2];
control[5] = 0.833*pointPtr[1] + 0.167*pointPtr[3];
control[6] = 0.5*pointPtr[0] + 0.5*pointPtr[2];
control[7] = 0.5*pointPtr[1] + 0.5*pointPtr[3];
psObj = Tcl_ObjPrintf(
"%.15g %.15g moveto\n"
"%.15g %.15g %.15g %.15g %.15g %.15g curveto\n",
control[0], Tk_CanvasPsY(canvas, control[1]),
control[2], Tk_CanvasPsY(canvas, control[3]),
control[4], Tk_CanvasPsY(canvas, control[5]),
control[6], Tk_CanvasPsY(canvas, control[7]));
} else {
closed = 0;
control[6] = pointPtr[0];
control[7] = pointPtr[1];
psObj = Tcl_ObjPrintf("%.15g %.15g moveto\n",
control[6], Tk_CanvasPsY(canvas, control[7]));
}
/*
* Cycle through all the remaining points in the curve, generating a curve
* section for each vertex in the linear path.
*/
for (i = numPoints-2, pointPtr += 2; i > 0; i--, pointPtr += 2) {
control[2] = 0.333*control[6] + 0.667*pointPtr[0];
control[3] = 0.333*control[7] + 0.667*pointPtr[1];
/*
* Set up the last two control points. This is done differently for
* the last spline of an open curve than for other cases.
*/
if ((i == 1) && !closed) {
control[6] = pointPtr[2];
control[7] = pointPtr[3];
} else {
control[6] = 0.5*pointPtr[0] + 0.5*pointPtr[2];
control[7] = 0.5*pointPtr[1] + 0.5*pointPtr[3];
}
control[4] = 0.333*control[6] + 0.667*pointPtr[0];
control[5] = 0.333*control[7] + 0.667*pointPtr[1];
Tcl_AppendPrintfToObj(psObj,
"%.15g %.15g %.15g %.15g %.15g %.15g curveto\n",
control[2], Tk_CanvasPsY(canvas, control[3]),
control[4], Tk_CanvasPsY(canvas, control[5]),
control[6], Tk_CanvasPsY(canvas, control[7]));
}
Tcl_AppendObjToObj(Tcl_GetObjResult(interp), psObj);
Tcl_DecrRefCount(psObj);
}
static int
TextToPostscript(
Tcl_Interp *interp, /* Leave Postscript or error message here. */
Tk_Canvas canvas, /* Information about overall canvas. */
Tk_Item *itemPtr, /* Item for which Postscript is wanted. */
int prepass) /* 1 means this is a prepass to collect font
* information; 0 means final Postscript is
* being created. */
{
TextItem *textPtr = (TextItem *) itemPtr;
double x, y;
Tk_FontMetrics fm;
const char *justify;
XColor *color;
Pixmap stipple;
Tk_State state = itemPtr->state;
Tcl_Obj *psObj;
Tcl_InterpState interpState;
if (state == TK_STATE_NULL) {
state = Canvas(canvas)->canvas_state;
}
color = textPtr->color;
stipple = textPtr->stipple;
if (state == TK_STATE_HIDDEN || textPtr->color == NULL ||
textPtr->text == NULL || *textPtr->text == 0) {
return TCL_OK;
} else if (Canvas(canvas)->currentItemPtr == itemPtr) {
if (textPtr->activeColor != NULL) {
color = textPtr->activeColor;
}
if (textPtr->activeStipple != None) {
stipple = textPtr->activeStipple;
}
} else if (state == TK_STATE_DISABLED) {
if (textPtr->disabledColor != NULL) {
color = textPtr->disabledColor;
}
if (textPtr->disabledStipple != None) {
stipple = textPtr->disabledStipple;
}
}
/*
* Make our working space.
*/
psObj = Tcl_NewObj();
interpState = Tcl_SaveInterpState(interp, TCL_OK);
/*
* Generate postscript.
*/
Tcl_ResetResult(interp);
if (Tk_CanvasPsFont(interp, canvas, textPtr->tkfont) != TCL_OK) {
goto error;
}
Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp));
if (prepass != 0) {
goto done;
}
Tcl_ResetResult(interp);
if (Tk_CanvasPsColor(interp, canvas, color) != TCL_OK) {
goto error;
}
Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp));
if (stipple != None) {
Tcl_ResetResult(interp);
Tk_CanvasPsStipple(interp, canvas, stipple);
Tcl_AppendPrintfToObj(psObj, "/StippleText {\n %s} bind def\n",
Tcl_GetString(Tcl_GetObjResult(interp)));
}
x = 0; y = 0; justify = NULL; /* lint. */
switch (textPtr->anchor) {
case TK_ANCHOR_NW: x = 0; y = 0; break;
case TK_ANCHOR_N: x = 1; y = 0; break;
case TK_ANCHOR_NE: x = 2; y = 0; break;
case TK_ANCHOR_E: x = 2; y = 1; break;
case TK_ANCHOR_SE: x = 2; y = 2; break;
case TK_ANCHOR_S: x = 1; y = 2; break;
case TK_ANCHOR_SW: x = 0; y = 2; break;
case TK_ANCHOR_W: x = 0; y = 1; break;
case TK_ANCHOR_CENTER: x = 1; y = 1; break;
}
switch (textPtr->justify) {
case TK_JUSTIFY_LEFT: justify = "0"; break;
case TK_JUSTIFY_CENTER: justify = "0.5"; break;
case TK_JUSTIFY_RIGHT: justify = "1"; break;
}
Tk_GetFontMetrics(textPtr->tkfont, &fm);
Tcl_AppendPrintfToObj(psObj, "%.15g %.15g %.15g [\n",
textPtr->angle, textPtr->x, Tk_CanvasPsY(canvas, textPtr->y));
Tcl_ResetResult(interp);
Tk_TextLayoutToPostscript(interp, textPtr->textLayout);
Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp));
Tcl_AppendPrintfToObj(psObj,
"] %d %g %g %s %s DrawText\n",
fm.linespace, x / -2.0, y / 2.0, justify,
((stipple == None) ? "false" : "true"));
/*
* Plug the accumulated postscript back into the result.
*/
done:
(void) Tcl_RestoreInterpState(interp, interpState);
Tcl_AppendObjToObj(Tcl_GetObjResult(interp), psObj);
Tcl_DecrRefCount(psObj);
return TCL_OK;
error:
Tcl_DiscardInterpState(interpState);
Tcl_DecrRefCount(psObj);
return TCL_ERROR;
}
void
Tcl_WrongNumArgs(
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments to print from objv. */
Tcl_Obj *const objv[], /* Initial argument objects, which should be
* included in the error message. */
const char *message) /* Error message to print after the leading
* objects in objv. The message may be
* NULL. */
{
Tcl_Obj *objPtr;
int i, len, elemLen, flags;
Interp *iPtr = (Interp *) interp;
const char *elementStr;
/*
* [incr Tcl] does something fairly horrific when generating error
* messages for its ensembles; it passes the whole set of ensemble
* arguments as a list in the first argument. This means that this code
* causes a problem in iTcl if it attempts to correctly quote all
* arguments, which would be the correct thing to do. We work around this
* nasty behaviour for now, and hope that we can remove it all in the
* future...
*/
#ifndef AVOID_HACKS_FOR_ITCL
int isFirst = 1; /* Special flag used to inhibit the treating
* of the first word as a list element so the
* hacky way Itcl generates error messages for
* its ensembles will still work. [Bug
* 1066837] */
# define MAY_QUOTE_WORD (!isFirst)
# define AFTER_FIRST_WORD (isFirst = 0)
#else /* !AVOID_HACKS_FOR_ITCL */
# define MAY_QUOTE_WORD 1
# define AFTER_FIRST_WORD (void) 0
#endif /* AVOID_HACKS_FOR_ITCL */
TclNewObj(objPtr);
if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) {
Tcl_AppendObjToObj(objPtr, Tcl_GetObjResult(interp));
Tcl_AppendToObj(objPtr, " or \"", -1);
} else {
Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
}
/*
* Check to see if we are processing an ensemble implementation, and if so
* rewrite the results in terms of how the ensemble was invoked.
*/
if (iPtr->ensembleRewrite.sourceObjs != NULL) {
int toSkip = iPtr->ensembleRewrite.numInsertedObjs;
int toPrint = iPtr->ensembleRewrite.numRemovedObjs;
Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs;
/*
* We only know how to do rewriting if all the replaced objects are
* actually arguments (in objv) to this function. Otherwise it just
* gets too complicated and we'd be better off just giving a slightly
* confusing error message...
*/
if (objc < toSkip) {
goto addNormalArgumentsToMessage;
}
/*
* Strip out the actual arguments that the ensemble inserted.
*/
objv += toSkip;
objc -= toSkip;
/*
* We assume no object is of index type.
*/
for (i=0 ; i<toPrint ; i++) {
/*
* Add the element, quoting it if necessary.
*/
if (origObjv[i]->typePtr == &indexType) {
register IndexRep *indexRep =
origObjv[i]->internalRep.twoPtrValue.ptr1;
elementStr = EXPAND_OF(indexRep);
elemLen = strlen(elementStr);
} else if (origObjv[i]->typePtr == &tclEnsembleCmdType) {
register EnsembleCmdRep *ecrPtr =
origObjv[i]->internalRep.twoPtrValue.ptr1;
elementStr = ecrPtr->fullSubcmdName;
elemLen = strlen(elementStr);
} else {
elementStr = TclGetStringFromObj(origObjv[i], &elemLen);
}
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
if (MAY_QUOTE_WORD && len != elemLen) {
char *quotedElementStr = TclStackAlloc(interp,
(unsigned)len + 1);
len = TclConvertElement(elementStr, elemLen,
quotedElementStr, flags);
Tcl_AppendToObj(objPtr, quotedElementStr, len);
TclStackFree(interp, quotedElementStr);
} else {
Tcl_AppendToObj(objPtr, elementStr, elemLen);
}
AFTER_FIRST_WORD;
/*
* Add a space if the word is not the last one (which has a
* moderately complex condition here).
*/
if (i<toPrint-1 || objc!=0 || message!=NULL) {
Tcl_AppendStringsToObj(objPtr, " ", NULL);
}
}
}
/*
* Now add the arguments (other than those rewritten) that the caller took
* from its calling context.
*/
addNormalArgumentsToMessage:
for (i = 0; i < objc; i++) {
/*
* If the object is an index type use the index table which allows for
* the correct error message even if the subcommand was abbreviated.
* Otherwise, just use the string rep.
*/
if (objv[i]->typePtr == &indexType) {
register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL);
} else if (objv[i]->typePtr == &tclEnsembleCmdType) {
register EnsembleCmdRep *ecrPtr =
objv[i]->internalRep.twoPtrValue.ptr1;
Tcl_AppendStringsToObj(objPtr, ecrPtr->fullSubcmdName, NULL);
} else {
/*
* Quote the argument if it contains spaces (Bug 942757).
*/
elementStr = TclGetStringFromObj(objv[i], &elemLen);
flags = 0;
len = TclScanElement(elementStr, elemLen, &flags);
if (MAY_QUOTE_WORD && len != elemLen) {
char *quotedElementStr = TclStackAlloc(interp,
(unsigned) len + 1);
len = TclConvertElement(elementStr, elemLen,
quotedElementStr, flags);
Tcl_AppendToObj(objPtr, quotedElementStr, len);
TclStackFree(interp, quotedElementStr);
} else {
Tcl_AppendToObj(objPtr, elementStr, elemLen);
}
}
AFTER_FIRST_WORD;
/*
* Append a space character (" ") if there is more text to follow
* (either another element from objv, or the message string).
*/
if (i<objc-1 || message!=NULL) {
Tcl_AppendStringsToObj(objPtr, " ", NULL);
}
}
/*
* Add any trailing message bits and set the resulting string as the
* interpreter result. Caller is responsible for reporting this as an
* actual error.
*/
if (message != NULL) {
Tcl_AppendStringsToObj(objPtr, message, NULL);
}
Tcl_AppendStringsToObj(objPtr, "\"", NULL);
Tcl_SetObjResult(interp, objPtr);
#undef MAY_QUOTE_WORD
#undef AFTER_FIRST_WORD
}
/* $scale set $newValue
*/
static int
ScaleSetCommand(
void *recordPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
{
Scale *scalePtr = recordPtr;
double from = 0.0, to = 1.0, value;
int result = TCL_OK;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "set value");
return TCL_ERROR;
}
if (Tcl_GetDoubleFromObj(interp, objv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
if (scalePtr->core.state & TTK_STATE_DISABLED) {
return TCL_OK;
}
/* ASSERT: fromObj and toObj are valid doubles.
*/
Tcl_GetDoubleFromObj(interp, scalePtr->scale.fromObj, &from);
Tcl_GetDoubleFromObj(interp, scalePtr->scale.toObj, &to);
/* Limit new value to between 'from' and 'to':
*/
if (from < to) {
value = value < from ? from : value > to ? to : value;
} else {
value = value < to ? to : value > from ? from : value;
}
/*
* Set value:
*/
Tcl_DecrRefCount(scalePtr->scale.valueObj);
scalePtr->scale.valueObj = Tcl_NewDoubleObj(value);
Tcl_IncrRefCount(scalePtr->scale.valueObj);
TtkRedisplayWidget(&scalePtr->core);
/*
* Set attached variable, if any:
*/
if (scalePtr->scale.variableObj != NULL) {
Tcl_ObjSetVar2(interp, scalePtr->scale.variableObj, NULL,
scalePtr->scale.valueObj, TCL_GLOBAL_ONLY);
}
if (WidgetDestroyed(&scalePtr->core)) {
return TCL_ERROR;
}
/*
* Invoke -command, if any:
*/
if (scalePtr->scale.commandObj != NULL) {
Tcl_Obj *cmdObj = Tcl_DuplicateObj(scalePtr->scale.commandObj);
Tcl_IncrRefCount(cmdObj);
Tcl_AppendToObj(cmdObj, " ", 1);
Tcl_AppendObjToObj(cmdObj, scalePtr->scale.valueObj);
result = Tcl_EvalObjEx(interp, cmdObj, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmdObj);
}
return result;
}
int
TclOO_Object_VarName(
ClientData clientData, /* Ignored. */
Tcl_Interp *interp, /* Interpreter in which to create the object;
* also used for error reporting. */
Tcl_ObjectContext context, /* The object/call context. */
int objc, /* Number of arguments. */
Tcl_Obj *const *objv) /* The actual arguments. */
{
Var *varPtr, *aryVar;
Tcl_Obj *varNamePtr, *argPtr;
const char *arg;
if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
"varName");
return TCL_ERROR;
}
argPtr = objv[objc-1];
arg = Tcl_GetString(argPtr);
/*
* Convert the variable name to fully-qualified form if it wasn't already.
* This has to be done prior to lookup because we can run into problems
* with resolvers otherwise. [Bug 3603695]
*
* We still need to do the lookup; the variable could be linked to another
* variable and we want the target's name.
*/
if (arg[0] == ':' && arg[1] == ':') {
varNamePtr = argPtr;
} else {
Tcl_Namespace *namespacePtr =
Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context));
varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1);
Tcl_AppendToObj(varNamePtr, "::", 2);
Tcl_AppendObjToObj(varNamePtr, argPtr);
}
Tcl_IncrRefCount(varNamePtr);
varPtr = TclObjLookupVar(interp, varNamePtr, NULL,
TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG, "refer to", 1, 1, &aryVar);
Tcl_DecrRefCount(varNamePtr);
if (varPtr == NULL) {
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", arg, NULL);
return TCL_ERROR;
}
/*
* Now that we've pinned down what variable we're really talking about
* (including traversing variable links), convert back to a name.
*/
varNamePtr = Tcl_NewObj();
if (aryVar != NULL) {
Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr);
/*
* WARNING! This code pokes inside the implementation of hash tables!
*/
hPtr = Tcl_FirstHashEntry((Tcl_HashTable *) aryVar->value.tablePtr,
&search);
while (hPtr != NULL) {
if (varPtr == Tcl_GetHashValue(hPtr)) {
Tcl_AppendToObj(varNamePtr, "(", -1);
Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr);
Tcl_AppendToObj(varNamePtr, ")", -1);
break;
}
hPtr = Tcl_NextHashEntry(&search);
}
} else {
Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr);
}
Tcl_SetObjResult(interp, varNamePtr);
return TCL_OK;
}
