/**
* P L O T _ L O A D M A T R I X
*
* Load a new transformation matrix. This will be followed by
* many calls to plot_draw().
*/
HIDDEN int
plot_loadMatrix(struct dm *dmp, fastf_t *mat, int which_eye)
{
Tcl_Obj *obj;
if (!dmp)
return TCL_ERROR;
obj = Tcl_GetObjResult(dmp->dm_interp);
if (Tcl_IsShared(obj))
obj = Tcl_DuplicateObj(obj);
if (((struct plot_vars *)dmp->dm_vars.priv_vars)->debug) {
struct bu_vls tmp_vls = BU_VLS_INIT_ZERO;
Tcl_AppendStringsToObj(obj, "plot_loadMatrix()\n", (char *)NULL);
bu_vls_printf(&tmp_vls, "which eye = %d\t", which_eye);
bu_vls_printf(&tmp_vls, "transformation matrix = \n");
bu_vls_printf(&tmp_vls, "%g %g %g %g\n", mat[0], mat[4], mat[8], mat[12]);
bu_vls_printf(&tmp_vls, "%g %g %g %g\n", mat[1], mat[5], mat[9], mat[13]);
bu_vls_printf(&tmp_vls, "%g %g %g %g\n", mat[2], mat[6], mat[10], mat[14]);
bu_vls_printf(&tmp_vls, "%g %g %g %g\n", mat[3], mat[7], mat[11], mat[15]);
Tcl_AppendStringsToObj(obj, bu_vls_addr(&tmp_vls), (char *)NULL);
bu_vls_free(&tmp_vls);
}
MAT_COPY(plotmat, mat);
Tcl_SetObjResult(dmp->dm_interp, obj);
return TCL_OK;
}
static int
SetFileReadOnly(
Tcl_Interp *interp, /* The interp to report errors with. */
int objIndex, /* The index of the attribute. */
char *fileName, /* The name of the file. */
Tcl_Obj *readOnlyPtr) /* The command line object. */
{
OSErr err;
FSSpec fileSpec;
HParamBlockRec paramBlock;
int hidden;
err = FSpLocationFromPath(strlen(fileName), fileName, &fileSpec);
if (err == noErr) {
if (Tcl_GetBooleanFromObj(interp, readOnlyPtr, &hidden) != TCL_OK) {
return TCL_ERROR;
}
paramBlock.fileParam.ioCompletion = NULL;
paramBlock.fileParam.ioNamePtr = fileSpec.name;
paramBlock.fileParam.ioVRefNum = fileSpec.vRefNum;
paramBlock.fileParam.ioDirID = fileSpec.parID;
if (hidden) {
err = PBHSetFLock(¶mBlock, 0);
} else {
err = PBHRstFLock(¶mBlock, 0);
}
}
if (err == fnfErr) {
long dirID;
Boolean isDirectory = 0;
err = FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory);
if ((err == noErr) && isDirectory) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot set a directory to read-only when File Sharing is turned off",
(char *) NULL);
return TCL_ERROR;
} else {
err = fnfErr;
}
}
if (err != noErr) {
errno = TclMacOSErrorToPosixError(err);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"couldn't set attributes for file \"", fileName, "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
winprint_print_text_options (struct winprint_data *wd, Tcl_Interp *interp,
int argc, char **argv,
struct print_text_options *pto)
{
int i;
pto->dialog = 1;
pto->parent = NULL;
pto->name = "";
pto->pageproc = NULL;
pto->postscript = 0;
pto->initproc = NULL;
for (i = 4; i < argc; i += 2)
{
if (i + 1 >= argc)
{
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"value for \"", argv[i], "\" missing",
(char *) NULL);
return TCL_ERROR;
}
if (strcmp (argv[i], "-dialog") == 0)
{
if (Tcl_GetBoolean (interp, argv[i + 1], &pto->dialog) != TCL_OK)
return TCL_ERROR;
}
else if (strcmp (argv[i], "-parent") == 0)
pto->parent = argv[i + 1];
else if (strcmp (argv[i], "-name") == 0)
pto->name = argv[i + 1];
else if (strcmp (argv[i], "-pageproc") == 0)
pto->pageproc = argv[i + 1];
else if (strcmp (argv[i], "-initproc") == 0)
pto->initproc = argv[i + 1];
else if (strcmp (argv[i], "-postscript") == 0)
pto->postscript = 1;
else
{
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"unknown option \"", argv[i], "\"",
(char *) NULL);
return TCL_ERROR;
}
}
return TCL_OK;
}
/* 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);
}
HIDDEN int
dm_bestXType_tcl(void *clientData, int argc, const char **argv)
{
Tcl_Interp *interp = (Tcl_Interp *)clientData;
Tcl_Obj *obj;
const char *best_dm;
char buffer[256] = {0};
if (argc != 2) {
struct bu_vls vls = BU_VLS_INIT_ZERO;
bu_vls_printf(&vls, "helplib dm_bestXType");
Tcl_Eval(interp, bu_vls_addr(&vls));
bu_vls_free(&vls);
return TCL_ERROR;
}
obj = Tcl_GetObjResult(interp);
if (Tcl_IsShared(obj))
obj = Tcl_DuplicateObj(obj);
snprintf(buffer, 256, "%s", argv[1]);
best_dm = dm_bestXType(buffer);
if (best_dm) {
Tcl_AppendStringsToObj(obj, best_dm, (char *)NULL);
Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
return TCL_ERROR;
}
static int
winprint_print_text_invoke (Tcl_Interp *interp, char *proc, const char *name,
enum winprint_query *result)
{
char *q;
if (Tcl_Eval (interp, proc) == TCL_ERROR)
return TCL_ERROR;
q = Tcl_GetStringFromObj (Tcl_GetObjResult (interp), (int *) NULL);
if (strcmp (q, "continue") == 0)
*result = Q_CONTINUE;
else if (strcmp (q, "newpage") == 0)
*result = Q_NEWPAGE;
else if (strcmp (q, "done") == 0)
*result = Q_DONE;
else
{
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"bad return from ", name, " procedure: \"",
q, "\"", (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static void
windows_error (Tcl_Interp *interp, const char *fn)
{
char buf[20];
sprintf (buf, "%lu", (unsigned long) GetLastError ());
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"Windows error in ", fn, ": ", buf, (char *) NULL);
}
static void
StatError(
Tcl_Interp *interp, /* The interp that has the error */
CONST char *fileName) /* The name of the file which caused the
* error. */
{
TclWinConvertError(GetLastError());
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"could not read \"", fileName, "\": ", Tcl_PosixError(interp),
(char *) NULL);
}
static int
GetFileFinderAttributes(
Tcl_Interp *interp, /* The interp to report errors with. */
int objIndex, /* The index of the attribute option. */
char *fileName, /* The name of the file. */
Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */
{
OSErr err;
FSSpec fileSpec;
FInfo finfo;
err = FSpLocationFromPath(strlen(fileName), fileName, &fileSpec);
if (err == noErr) {
err = FSpGetFInfo(&fileSpec, &finfo);
}
if (err == noErr) {
switch (objIndex) {
case MAC_CREATOR_ATTRIBUTE:
*attributePtrPtr = Tcl_NewOSTypeObj(finfo.fdCreator);
break;
case MAC_HIDDEN_ATTRIBUTE:
*attributePtrPtr = Tcl_NewBooleanObj(finfo.fdFlags
& kIsInvisible);
break;
case MAC_TYPE_ATTRIBUTE:
*attributePtrPtr = Tcl_NewOSTypeObj(finfo.fdType);
break;
}
} else if (err == fnfErr) {
long dirID;
Boolean isDirectory = 0;
err = FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory);
if ((err == noErr) && isDirectory) {
if (objIndex == MAC_HIDDEN_ATTRIBUTE) {
*attributePtrPtr = Tcl_NewBooleanObj(0);
} else {
*attributePtrPtr = Tcl_NewOSTypeObj('Fldr');
}
}
}
if (err != noErr) {
errno = TclMacOSErrorToPosixError(err);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"couldn't get attributes for file \"", fileName, "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
CannotSetAttribute(
Tcl_Interp *interp, /* The interp we are using for errors. */
int objIndex, /* The index of the attribute. */
char *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The new value of the attribute. */
{
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot set attribute \"", tclpFileAttrStrings[objIndex],
"\" for file \"", fileName, "\" : attribute is readonly",
(char *) NULL);
return TCL_ERROR;
}
static void
AttributesPosixError(
Tcl_Interp *interp, /* The interp that has the error */
int objIndex, /* The attribute which caused the problem. */
char *fileName, /* The name of the file which caused the
* error. */
int getOrSet) /* 0 for get; 1 for set */
{
TclWinConvertError(GetLastError());
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"cannot ", getOrSet ? "set" : "get", " attribute \"",
tclpFileAttrStrings[objIndex], "\" for file \"", fileName,
"\": ", Tcl_PosixError(interp), (char *) NULL);
}
HIDDEN int
plot_logfile(struct dm *dmp, const char *filename)
{
Tcl_Obj *obj;
obj = Tcl_GetObjResult(dmp->dm_interp);
if (Tcl_IsShared(obj))
obj = Tcl_DuplicateObj(obj);
bu_vls_sprintf(&dmp->dm_log, "%s", filename);
(void)fflush(((struct plot_vars *)dmp->dm_vars.priv_vars)->up_fp);
Tcl_AppendStringsToObj(obj, "flushed\n", (char *)NULL);
Tcl_SetObjResult(dmp->dm_interp, obj);
return TCL_OK;
}
int
TnmGetTableKeyFromObj(Tcl_Interp *interp, TnmTable *table, Tcl_Obj *objPtr, char *what)
{
char *name;
int value;
name = Tcl_GetStringFromObj(objPtr, NULL);
value = TnmGetTableKey(table, name);
if (value == -1 && interp) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "unknown ",
what, " \"", name, "\": should be ",
TnmGetTableValues(table), (char *) NULL);
}
return value;
}
HIDDEN int
plot_debug(struct dm *dmp, int lvl)
{
Tcl_Obj *obj;
obj = Tcl_GetObjResult(dmp->dm_interp);
if (Tcl_IsShared(obj))
obj = Tcl_DuplicateObj(obj);
dmp->dm_debugLevel = lvl;
(void)fflush(((struct plot_vars *)dmp->dm_vars.priv_vars)->up_fp);
Tcl_AppendStringsToObj(obj, "flushed\n", (char *)NULL);
Tcl_SetObjResult(dmp->dm_interp, obj);
return TCL_OK;
}
static int
FindPathStyle(Tcl_Interp *interp, Tcl_Obj *nameObj, Tcl_HashTable *tablePtr, Tk_PathStyle **s)
{
Tcl_HashEntry *hPtr;
char *name = Tcl_GetString(nameObj);
*s = NULL;
hPtr = Tcl_FindHashEntry(tablePtr, name);
if (hPtr == NULL) {
Tcl_Obj *resultObj;
resultObj = Tcl_NewStringObj("style \"", -1);
Tcl_AppendStringsToObj(resultObj, name, "\" doesn't exist", (char *) NULL);
Tcl_SetObjResult(interp, resultObj);
return TCL_ERROR;
}
*s = (Tk_PathStyle *) Tcl_GetHashValue(hPtr);
return TCL_OK;
}
static int
FindGradientMaster(Tcl_Interp *interp, Tcl_Obj *nameObj, Tcl_HashTable *tablePtr,
TkPathGradientMaster **g)
{
Tcl_HashEntry *hPtr;
char *name = Tcl_GetString(nameObj);
*g = NULL;
hPtr = Tcl_FindHashEntry(tablePtr, name);
if (hPtr == NULL) {
Tcl_Obj *resultObj;
resultObj = Tcl_NewStringObj("gradient \"", -1);
Tcl_AppendStringsToObj(resultObj, name, "\" doesn't exist", (char *) NULL);
Tcl_SetObjResult(interp, resultObj);
return TCL_ERROR;
}
*g = (TkPathGradientMaster *) Tcl_GetHashValue(hPtr);
return TCL_OK;
}
static int
GetFileReadOnly(
Tcl_Interp *interp, /* The interp to report errors with. */
int objIndex, /* The index of the attribute. */
char *fileName, /* The name of the file. */
Tcl_Obj **readOnlyPtrPtr) /* A pointer to return the object with. */
{
OSErr err;
FSSpec fileSpec;
CInfoPBRec paramBlock;
err = FSpLocationFromPath(strlen(fileName), fileName, &fileSpec);
if (err == noErr) {
if (err == noErr) {
paramBlock.hFileInfo.ioCompletion = NULL;
paramBlock.hFileInfo.ioNamePtr = fileSpec.name;
paramBlock.hFileInfo.ioVRefNum = fileSpec.vRefNum;
paramBlock.hFileInfo.ioFDirIndex = 0;
paramBlock.hFileInfo.ioDirID = fileSpec.parID;
err = PBGetCatInfo(¶mBlock, 0);
if (err == noErr) {
/*
* For some unknown reason, the Mac does not give
* symbols for the bits in the ioFlAttrib field.
* 1 -> locked.
*/
*readOnlyPtrPtr = Tcl_NewBooleanObj(
paramBlock.hFileInfo.ioFlAttrib & 1);
}
}
}
if (err != noErr) {
errno = TclMacOSErrorToPosixError(err);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"couldn't get attributes for file \"", fileName, "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itk_ArchOptAccessError()
*
* Simply utility which adds error information after an option
* value access fails. Adds traceback information to the given
* interpreter.
* ------------------------------------------------------------------------
*/
void
Itk_ArchOptAccessError(
Tcl_Interp *interp, /* interpreter handling this object */
ArchInfo *info, /* info associated with mega-widget */
ArchOption *archOpt) /* option that couldn't be accessed */
{
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"internal error: cannot access itk_option(", archOpt->switchName, ")",
(char*)NULL);
if (info->itclObj->accessCmd) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
Tcl_AppendToObj(resultPtr, " in widget \"", -1);
Tcl_GetCommandFullName(interp, info->itclObj->accessCmd, resultPtr);
Tcl_AppendToObj(resultPtr, "\"", -1);
}
}
int
ThreadpKill (Tcl_Interp *interp, long id)
{
HANDLE hThread;
int result = TCL_OK;
if (winOpenThreadProc) {
hThread = winOpenThreadProc(THREAD_TERMINATE, FALSE, id);
/*
* not to be misunderstood as "devilishly clever",
* but evil in it's pure form.
*/
TerminateThread(hThread, 666);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"Can't (yet) kill threads on this OS, sorry.", NULL);
result = TCL_ERROR;
}
return result;
}
HIDDEN int
dm_validXType_tcl(void *clientData, int argc, const char **argv)
{
Tcl_Interp *interp = (Tcl_Interp *)clientData;
struct bu_vls vls = BU_VLS_INIT_ZERO;
Tcl_Obj *obj;
if (argc != 3) {
bu_vls_printf(&vls, "helplib dm_validXType");
Tcl_Eval(interp, bu_vls_addr(&vls));
bu_vls_free(&vls);
return TCL_ERROR;
}
bu_vls_printf(&vls, "%d", dm_validXType(argv[1], argv[2]));
obj = Tcl_GetObjResult(interp);
if (Tcl_IsShared(obj))
obj = Tcl_DuplicateObj(obj);
Tcl_AppendStringsToObj(obj, bu_vls_addr(&vls), (char *)NULL);
bu_vls_free(&vls);
Tcl_SetObjResult(interp, obj);
return TCL_OK;
}
/*
* ------------------------------------------------------------------------
* Itk_GetArchInfo()
*
* Finds the extra Archetype info associated with the given object.
* Returns TCL_OK and a pointer to the info if found. Returns
* TCL_ERROR along with an error message in interp->result if not.
* ------------------------------------------------------------------------
*/
int
Itk_GetArchInfo(
Tcl_Interp *interp, /* interpreter handling this object */
ItclObject *contextObj, /* object with desired data */
ArchInfo **infoPtr) /* returns: pointer to extra info */
{
Tcl_HashTable *objsWithArchInfo;
Tcl_HashEntry *entry;
/*
* If there is any problem finding the info, return an error.
*/
objsWithArchInfo = ItkGetObjsWithArchInfo(interp);
entry = Tcl_FindHashEntry(objsWithArchInfo, (char*)contextObj);
if (!entry) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"internal error: no Archetype information for widget",
(char*)NULL);
if (contextObj->accessCmd) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
Tcl_AppendToObj(resultPtr, " \"", -1);
Tcl_GetCommandFullName(interp, contextObj->accessCmd, resultPtr);
Tcl_AppendToObj(resultPtr, "\"", -1);
}
return TCL_ERROR;
}
/*
* Otherwise, return the requested info.
*/
*infoPtr = (ArchInfo*)Tcl_GetHashValue(entry);
return TCL_OK;
}
static int
SetFileFinderAttributes(
Tcl_Interp *interp, /* The interp to report errors with. */
int objIndex, /* The index of the attribute. */
char *fileName, /* The name of the file. */
Tcl_Obj *attributePtr) /* The command line object. */
{
OSErr err;
FSSpec fileSpec;
FInfo finfo;
err = FSpLocationFromPath(strlen(fileName), fileName, &fileSpec);
if (err == noErr) {
err = FSpGetFInfo(&fileSpec, &finfo);
}
if (err == noErr) {
switch (objIndex) {
case MAC_CREATOR_ATTRIBUTE:
if (Tcl_GetOSTypeFromObj(interp, attributePtr,
&finfo.fdCreator) != TCL_OK) {
return TCL_ERROR;
}
break;
case MAC_HIDDEN_ATTRIBUTE: {
int hidden;
if (Tcl_GetBooleanFromObj(interp, attributePtr, &hidden)
!= TCL_OK) {
return TCL_ERROR;
}
if (hidden) {
finfo.fdFlags |= kIsInvisible;
} else {
finfo.fdFlags &= ~kIsInvisible;
}
break;
}
case MAC_TYPE_ATTRIBUTE:
if (Tcl_GetOSTypeFromObj(interp, attributePtr,
&finfo.fdType) != TCL_OK) {
return TCL_ERROR;
}
break;
}
err = FSpSetFInfo(&fileSpec, &finfo);
} else if (err == fnfErr) {
long dirID;
Boolean isDirectory = 0;
err = FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory);
if ((err == noErr) && isDirectory) {
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
Tcl_AppendStringsToObj(resultPtr, "cannot set ",
tclpFileAttrStrings[objIndex], ": \"",
fileName, "\" is a directory", (char *) NULL);
return TCL_ERROR;
}
}
if (err != noErr) {
errno = TclMacOSErrorToPosixError(err);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"couldn't set attributes for file \"", fileName, "\": ",
Tcl_PosixError(interp), (char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
int
Tcl_GetIndexFromObjStruct(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr, /* Object containing the string to lookup. */
const void *tablePtr, /* The first string in the table. The second
* string will be at this address plus the
* offset, the third plus the offset again,
* etc. The last entry must be NULL and there
* must not be duplicate entries. */
int offset, /* The number of bytes between entries */
const char *msg, /* Identifying word to use in error
* messages. */
int flags, /* 0 or TCL_EXACT */
int *indexPtr) /* Place to store resulting integer index. */
{
int index, idx, numAbbrev;
char *key, *p1;
const char *p2;
const char *const *entryPtr;
Tcl_Obj *resultPtr;
IndexRep *indexRep;
/* Protect against invalid values, like -1 or 0. */
if (offset < (int)sizeof(char *)) {
offset = (int)sizeof(char *);
}
/*
* See if there is a valid cached result from a previous lookup.
*/
if (objPtr->typePtr == &indexType) {
indexRep = objPtr->internalRep.twoPtrValue.ptr1;
if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) {
*indexPtr = indexRep->index;
return TCL_OK;
}
}
/*
* Lookup the value of the object in the table. Accept unique
* abbreviations unless TCL_EXACT is set in flags.
*/
key = TclGetString(objPtr);
index = -1;
numAbbrev = 0;
/*
* Scan the table looking for one of:
* - An exact match (always preferred)
* - A single abbreviation (allowed depending on flags)
* - Several abbreviations (never allowed, but overridden by exact match)
*/
for (entryPtr = tablePtr, idx = 0; *entryPtr != NULL;
entryPtr = NEXT_ENTRY(entryPtr, offset), idx++) {
for (p1 = key, p2 = *entryPtr; *p1 == *p2; p1++, p2++) {
if (*p1 == '\0') {
index = idx;
goto done;
}
}
if (*p1 == '\0') {
/*
* The value is an abbreviation for this entry. Continue checking
* other entries to make sure it's unique. If we get more than one
* unique abbreviation, keep searching to see if there is an exact
* match, but remember the number of unique abbreviations and
* don't allow either.
*/
numAbbrev++;
index = idx;
}
}
/*
* Check if we were instructed to disallow abbreviations.
*/
if ((flags & TCL_EXACT) || (key[0] == '\0') || (numAbbrev != 1)) {
goto error;
}
done:
/*
* Cache the found representation. Note that we want to avoid allocating a
* new internal-rep if at all possible since that is potentially a slow
* operation.
*/
if (objPtr->typePtr == &indexType) {
indexRep = objPtr->internalRep.twoPtrValue.ptr1;
} else {
TclFreeIntRep(objPtr);
indexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
objPtr->internalRep.twoPtrValue.ptr1 = indexRep;
objPtr->typePtr = &indexType;
}
indexRep->tablePtr = (void *) tablePtr;
indexRep->offset = offset;
indexRep->index = index;
*indexPtr = index;
return TCL_OK;
error:
if (interp != NULL) {
/*
* Produce a fancy error message.
*/
int count = 0;
TclNewObj(resultPtr);
Tcl_SetObjResult(interp, resultPtr);
entryPtr = tablePtr;
while ((*entryPtr != NULL) && !**entryPtr) {
entryPtr = NEXT_ENTRY(entryPtr, offset);
}
Tcl_AppendStringsToObj(resultPtr, (numAbbrev > 1) &&
!(flags & TCL_EXACT) ? "ambiguous " : "bad ", msg, " \"", key,
"\": must be ", *entryPtr, NULL);
entryPtr = NEXT_ENTRY(entryPtr, offset);
while (*entryPtr != NULL) {
if (*NEXT_ENTRY(entryPtr, offset) == NULL) {
Tcl_AppendStringsToObj(resultPtr, ((count > 0) ? "," : ""),
" or ", *entryPtr, NULL);
} else if (**entryPtr) {
Tcl_AppendStringsToObj(resultPtr, ", ", *entryPtr, NULL);
count++;
}
entryPtr = NEXT_ENTRY(entryPtr, offset);
}
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL);
}
return TCL_ERROR;
}
static int
win_choose_font (ClientData cd, Tcl_Interp *interp, int argc, char **argv)
{
char *deffont;
Tk_Window parent;
int i, oldMode;
CHOOSEFONT cf;
LOGFONT lf;
HDC hdc;
HFONT hfont;
char facebuf[LF_FACESIZE];
TEXTMETRIC tm;
int pointsize;
char *s;
Tcl_DString resultStr; /* used to translate result in UTF8 in Tcl/Tk8.1 */
deffont = NULL;
parent = Tk_MainWindow (interp);
for (i = 1; i < argc; i += 2)
{
if (i + 1 >= argc)
{
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"value for \"", argv[i], "\" missing",
(char *) NULL);
return TCL_ERROR;
}
if (strcmp (argv[i], "-default") == 0)
deffont = argv[i + 1];
else if (strcmp (argv[i], "-parent") == 0)
{
parent = Tk_NameToWindow (interp, argv[i + 1],
Tk_MainWindow (interp));
if (parent == NULL)
return TCL_ERROR;
}
else
{
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"unknown option \"", argv[i], "\"",
(char *) NULL);
return TCL_ERROR;
}
}
memset (&cf, 0, sizeof (CHOOSEFONT));
cf.lStructSize = sizeof (CHOOSEFONT);
if (Tk_WindowId (parent) == None)
Tk_MakeWindowExist (parent);
cf.hwndOwner = Tk_GetHWND (Tk_WindowId (parent));
cf.lpLogFont = &lf;
cf.Flags = CF_SCREENFONTS | CF_FORCEFONTEXIST;
memset (&lf, 0, sizeof (LOGFONT));
if (deffont != NULL)
{
Tk_Font tkfont;
const TkFontAttributes *fa;
tkfont = Tk_GetFont (interp, parent, deffont);
if (tkfont == NULL)
return TCL_ERROR;
cf.Flags |= CF_INITTOLOGFONTSTRUCT;
/* In order to initialize LOGFONT, we need to extract the real
font attributes from the Tk internal font information. */
fa = &((TkFont *) tkfont)->fa;
/* This code is taken from TkpGetFontFromAttributes. It
converts a TkFontAttributes structure into a LOGFONT
structure. */
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
lf.lfHeight = - fa->size;
#else
lf.lfHeight = - fa->pointsize;
#endif
if (lf.lfHeight < 0)
lf.lfHeight = MulDiv (lf.lfHeight,
254 * WidthOfScreen (Tk_Screen (parent)),
720 * WidthMMOfScreen (Tk_Screen (parent)));
lf.lfWeight = fa->weight == TK_FW_NORMAL ? FW_NORMAL : FW_BOLD;
lf.lfItalic = fa->slant;
lf.lfUnderline = fa->underline;
lf.lfStrikeOut = fa->overstrike;
lf.lfCharSet = DEFAULT_CHARSET;
lf.lfOutPrecision = OUT_DEFAULT_PRECIS;
lf.lfClipPrecision = CLIP_DEFAULT_PRECIS;
lf.lfQuality = DEFAULT_QUALITY;
lf.lfPitchAndFamily = DEFAULT_PITCH | FF_DONTCARE;
if (fa->family == NULL)
lf.lfFaceName[0] = '\0';
else
strncpy (lf.lfFaceName, fa->family, sizeof (lf.lfFaceName));
Tk_FreeFont (tkfont);
}
oldMode = Tcl_SetServiceMode(TCL_SERVICE_ALL);
if (! ChooseFont (&cf))
{
DWORD code;
code = CommDlgExtendedError ();
if (code == 0)
{
/* The user pressed cancel. */
Tcl_ResetResult (interp);
return TCL_OK;
}
else
{
char buf[200];
sprintf (buf, "Windows common dialog error 0x%lx", (unsigned long) code);
Tcl_ResetResult (interp);
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, buf, -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr, buf, -1);
#endif
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
Tcl_DStringValue(&resultStr),
(char *) NULL);
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
}
Tcl_SetServiceMode(oldMode);
/* We now have a LOGFONT structure. We store it into a device
context, and then extract enough information to build a Tk font
specification. With luck, when Tk interprets the font
specification it will wind up with the font that the user expects
to see. Some of this code is taken from AllocFont. */
hfont = CreateFontIndirect (&lf);
if (hfont == NULL)
{
/* This should be impossible. */
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, "CreateFontIndirect failed on chosen font", -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr, "CreateFontIndirect failed on chosen font", -1);
#endif
Tcl_SetResult (interp, Tcl_DStringValue(&resultStr), TCL_STATIC);
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
hdc = GetDC (cf.hwndOwner);
hfont = SelectObject (hdc, hfont);
GetTextFace (hdc, sizeof (facebuf), facebuf);
GetTextMetrics (hdc, &tm);
Tcl_ResetResult (interp);
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, facebuf, -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr,facebuf,-1);
#endif
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1)) != TCL_OK) {
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
Tcl_DStringFree(&resultStr);
pointsize = MulDiv (tm.tmHeight - tm.tmInternalLeading,
720 * WidthMMOfScreen (Tk_Screen (parent)),
254 * WidthOfScreen (Tk_Screen (parent)));
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewIntObj (pointsize)) != TCL_OK) {
return TCL_ERROR;
}
if (tm.tmWeight > FW_MEDIUM)
s = "bold";
else
s = "normal";
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, s, -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr, s, -1);
#endif
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1)) != TCL_OK) {
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
Tcl_DStringFree(&resultStr);
if (tm.tmItalic)
s = "italic";
else
s = "roman";
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, s, -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr, s, -1);
#endif
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1)) != TCL_OK) {
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
Tcl_DStringFree(&resultStr);
if (tm.tmUnderlined)
{
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, "underline", -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr,"underline",-1);
#endif
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1))
!= TCL_OK) {
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
Tcl_DStringFree(&resultStr);
}
if (tm.tmStruckOut)
{
#if (TCL_MAJOR_VERSION >= 8) && (TCL_MINOR_VERSION >= 1)
Tcl_ExternalToUtfDString(NULL, "overstrike", -1, &resultStr);
#else
Tcl_InitDString(&resultStr);
Tcl_DStingAppend(&resultStr, "overstrike", -1);
#endif
if (Tcl_ListObjAppendElement (interp, Tcl_GetObjResult (interp),
Tcl_NewStringObj (Tcl_DStringValue(&resultStr), -1))
!= TCL_OK) {
Tcl_DStringFree(&resultStr);
return TCL_ERROR;
}
Tcl_DStringFree(&resultStr);
}
hfont = SelectObject (hdc, hfont);
ReleaseDC (cf.hwndOwner, hdc);
DeleteObject (hfont);
return TCL_OK;
}
////////////////////////////////////////////////////
// ::bonjour::register command
////////////////////////////////////////////////////
static int bonjour_register(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]
) {
const char *serviceName = NULL;
const char *regtype = NULL;
unsigned int port;
active_registration *activeRegister;
Tcl_HashTable *registerRegistrations = (Tcl_HashTable *)clientData;
Tcl_HashEntry *hashEntry;
int newFlag = 0;
uint16_t txtLen = 0;
void *txtRecord = NULL;
static const char *options[] = { "-name", "--", NULL };
enum optionIndex { OPT_NAME, OPT_END };
// parse options
int objIndex;
for(objIndex = 1; objIndex < objc; objIndex++) {
if(Tcl_GetString(objv[objIndex])[0] != '-') {
break;
}
int index;
if(Tcl_GetIndexFromObj(interp, objv[objIndex], options, "option", 0, &index) == TCL_ERROR) {
return TCL_ERROR;
}
if(index == OPT_NAME) {
objIndex++;
serviceName = Tcl_GetString(objv[objIndex]);
}
else if(index == OPT_END) {
objIndex++;
break;
}
}
int numArgs = objc - objIndex;
if(numArgs < 2 || numArgs > 3)
{
Tcl_WrongNumArgs(interp, 1, objv, "?switches? <regtype> <port> ?txt-record-list?");
return(TCL_ERROR);
}
// retrieve the registration type (service name)
regtype = Tcl_GetString(objv[objIndex]);
// retrieve the port number
if(Tcl_GetIntFromObj(interp, objv[objIndex + 1], (int *)&port) != TCL_OK)
return TCL_ERROR;
// retrieve the txt record list, if applicable
if(numArgs == 3)
{
list2txt(objv[objIndex + 2], &txtLen, &txtRecord);
}
// attempt to create an entry in the hash table
// for this regtype
hashEntry =
Tcl_CreateHashEntry(registerRegistrations, regtype, &newFlag);
// if an entry already exists, return an error
if(!newFlag) {
Tcl_Obj *errorMsg = Tcl_NewStringObj(NULL, 0);
Tcl_AppendStringsToObj(
errorMsg, "regtype ", regtype, " is already registered", NULL);
Tcl_SetObjResult(interp, errorMsg);
return(TCL_ERROR);
}
// create the activeRegister structure
activeRegister = (active_registration *)ckalloc(sizeof(active_registration));
activeRegister->regtype = (char *)ckalloc(strlen(regtype) + 1);
strcpy(activeRegister->regtype, regtype);
// store the activeRegister structure
Tcl_SetHashValue(hashEntry, activeRegister);
DNSServiceErrorType error =
DNSServiceRegister(&activeRegister->sdRef,
0, 0,
serviceName, regtype,
NULL, NULL,
htons((uint16_t)port),
txtLen, txtRecord, // txt record stuff
NULL, NULL); // callback stuff
// free the txt record
ckfree(txtRecord);
if(error != kDNSServiceErr_NoError)
{
ckfree(activeRegister->regtype);
ckfree((void *)activeRegister);
Tcl_DeleteHashEntry(hashEntry);
Tcl_SetObjResult(interp, create_dnsservice_error(interp, "DNSServiceRegister", error));
return TCL_ERROR;
}
return TCL_OK;
}
/*
* P L O T _ O P E N
*
* Fire up the display manager, and the display processor.
*
*/
struct dm *
plot_open(Tcl_Interp *interp, int argc, const char *argv[])
{
static int count = 0;
struct dm *dmp;
Tcl_Obj *obj;
BU_ALLOC(dmp, struct dm);
*dmp = dm_plot; /* struct copy */
dmp->dm_interp = interp;
BU_ALLOC(dmp->dm_vars.priv_vars, struct plot_vars);
obj = Tcl_GetObjResult(interp);
if (Tcl_IsShared(obj))
obj = Tcl_DuplicateObj(obj);
bu_vls_init(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls);
bu_vls_init(&dmp->dm_pathName);
bu_vls_init(&dmp->dm_tkName);
bu_vls_printf(&dmp->dm_pathName, ".dm_plot%d", count++);
bu_vls_printf(&dmp->dm_tkName, "dm_plot%d", count++);
/* skip first argument */
--argc; ++argv;
/* Process any options */
((struct plot_vars *)dmp->dm_vars.priv_vars)->is_3D = 1; /* 3-D w/color, by default */
while (argv[0] != (char *)0 && argv[0][0] == '-') {
switch (argv[0][1]) {
case '3':
break;
case '2':
((struct plot_vars *)dmp->dm_vars.priv_vars)->is_3D = 0; /* 2-D, for portability */
break;
case 'g':
((struct plot_vars *)dmp->dm_vars.priv_vars)->grid = 1;
break;
case 'f':
((struct plot_vars *)dmp->dm_vars.priv_vars)->floating = 1;
break;
case 'z':
case 'Z':
/* Enable Z clipping */
Tcl_AppendStringsToObj(obj, "Clipped in Z to viewing cube\n", (char *)NULL);
dmp->dm_zclip = 1;
break;
default:
Tcl_AppendStringsToObj(obj, "bad PLOT option ", argv[0], "\n", (char *)NULL);
(void)plot_close(dmp);
Tcl_SetObjResult(interp, obj);
return DM_NULL;
}
argv++;
}
if (argv[0] == (char *)0) {
Tcl_AppendStringsToObj(obj, "no filename or filter specified\n", (char *)NULL);
(void)plot_close(dmp);
Tcl_SetObjResult(interp, obj);
return DM_NULL;
}
if (argv[0][0] == '|') {
bu_vls_strcpy(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls, &argv[0][1]);
while ((++argv)[0] != (char *)0) {
bu_vls_strcat(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls, " ");
bu_vls_strcat(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls, argv[0]);
}
((struct plot_vars *)dmp->dm_vars.priv_vars)->is_pipe = 1;
} else {
bu_vls_strcpy(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls, argv[0]);
}
if (((struct plot_vars *)dmp->dm_vars.priv_vars)->is_pipe) {
if ((((struct plot_vars *)dmp->dm_vars.priv_vars)->up_fp =
popen(bu_vls_addr(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls), "w")) == NULL) {
perror(bu_vls_addr(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls));
(void)plot_close(dmp);
Tcl_SetObjResult(interp, obj);
return DM_NULL;
}
Tcl_AppendStringsToObj(obj, "piped to ",
bu_vls_addr(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls),
"\n", (char *)NULL);
} else {
if ((((struct plot_vars *)dmp->dm_vars.priv_vars)->up_fp =
fopen(bu_vls_addr(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls), "wb")) == NULL) {
perror(bu_vls_addr(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls));
(void)plot_close(dmp);
Tcl_SetObjResult(interp, obj);
return DM_NULL;
}
Tcl_AppendStringsToObj(obj, "plot stored in ",
bu_vls_addr(&((struct plot_vars *)dmp->dm_vars.priv_vars)->vls),
"\n", (char *)NULL);
}
setbuf(((struct plot_vars *)dmp->dm_vars.priv_vars)->up_fp,
((struct plot_vars *)dmp->dm_vars.priv_vars)->ttybuf);
if (((struct plot_vars *)dmp->dm_vars.priv_vars)->is_3D)
pl_3space(((struct plot_vars *)dmp->dm_vars.priv_vars)->up_fp,
-2048, -2048, -2048, 2048, 2048, 2048);
else
pl_space(((struct plot_vars *)dmp->dm_vars.priv_vars)->up_fp,
-2048, -2048, 2048, 2048);
MAT_IDN(plotmat);
Tcl_SetObjResult(interp, obj);
return dmp;
}
static int
winprint_print_text_dialog (struct winprint_data *wd, Tcl_Interp *interp,
const struct print_text_options *pto,
PRINTDLG *pd, int *cancelled)
{
int mode, ret;
*cancelled = 0;
memset (pd, 0, sizeof (PRINTDLG));
pd->lStructSize = sizeof (PRINTDLG);
if (! pto->dialog)
pd->Flags = PD_RETURNDEFAULT | PD_RETURNDC;
else
{
Tk_Window parent;
if (pto->parent == NULL)
parent = Tk_MainWindow (interp);
else
{
parent = Tk_NameToWindow (interp, pto->parent,
Tk_MainWindow (interp));
if (parent == NULL)
return TCL_ERROR;
}
if (Tk_WindowId (parent) == None)
Tk_MakeWindowExist (parent);
pd->hwndOwner = Tk_GetHWND (Tk_WindowId (parent));
if (wd->page_setup != NULL)
{
pd->hDevMode = wd->page_setup->hDevMode;
pd->hDevNames = wd->page_setup->hDevNames;
}
pd->Flags = PD_NOSELECTION | PD_RETURNDC | PD_USEDEVMODECOPIES;
pd->nCopies = 1;
pd->nFromPage = 1;
pd->nToPage = 1;
pd->nMinPage = 1;
pd->nMaxPage = 0xffff;
}
mode = Tcl_SetServiceMode (TCL_SERVICE_ALL);
ret = PrintDlg (pd);
(void) Tcl_SetServiceMode (mode);
if (! ret)
{
DWORD code;
code = CommDlgExtendedError ();
/* For some errors, the print dialog will already have reported
an error. We treat those as though the user pressed cancel.
Unfortunately, I do not know just which errors those are. */
if (code == 0 || code == PDERR_NODEFAULTPRN)
{
*cancelled = 1;
return TCL_OK;
}
else
{
char buf[20];
sprintf (buf, "0x%lx", (unsigned long) code);
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"Windows common dialog error ", buf,
(char *) NULL);
return TCL_ERROR;
}
}
return TCL_OK;
}
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
}
static int
TestobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int varIndex, destIndex, i;
const char *index, *subCmd, *string;
const Tcl_ObjType *targetType;
if (objc < 2) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "assign") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(objv[3]);
if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(destIndex, varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[destIndex]);
} else if (strcmp(subCmd, "convert") == 0) {
const char *typeName;
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
typeName = Tcl_GetString(objv[3]);
if ((targetType = Tcl_GetObjType(typeName)) == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"no type ", typeName, " found", NULL);
return TCL_ERROR;
}
if (Tcl_ConvertToType(interp, varPtr[varIndex], targetType)
!= TCL_OK) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "duplicate") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(objv[3]);
if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
Tcl_SetObjResult(interp, varPtr[destIndex]);
} else if (strcmp(subCmd, "freeallvars") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
for (i = 0; i < NUMBER_OF_OBJECT_VARS; i++) {
if (varPtr[i] != NULL) {
Tcl_DecrRefCount(varPtr[i]);
varPtr[i] = NULL;
}
}
} else if (strcmp(subCmd, "invalidateStringRep") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_InvalidateStringRep(varPtr[varIndex]);
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "newobj") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
SetVarToObj(varIndex, Tcl_NewObj());
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "objtype") == 0) {
const char *typeName;
/*
* Return an object containing the name of the argument's type of
* internal rep. If none exists, return "none".
*/
if (objc != 3) {
goto wrongNumArgs;
}
if (objv[2]->typePtr == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
} else {
typeName = objv[2]->typePtr->name;
Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
}
} else if (strcmp(subCmd, "refcount") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount));
} else if (strcmp(subCmd, "type") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
} else {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
varPtr[varIndex]->typePtr->name, -1);
}
} else if (strcmp(subCmd, "types") == 0) {
if (objc != 2) {
goto wrongNumArgs;
}
if (Tcl_AppendAllObjTypes(interp,
Tcl_GetObjResult(interp)) != TCL_OK) {
return TCL_ERROR;
}
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be assign, convert, duplicate, freeallvars, "
"newobj, objcount, objtype, refcount, type, or types", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
winprint_page_setup_command (ClientData cd, Tcl_Interp *interp, int argc,
char **argv)
{
struct winprint_data *wd = (struct winprint_data *) cd;
Tk_Window parent;
int i, mode, ret;
PAGESETUPDLG psd;
parent = Tk_MainWindow (interp);
for (i = 2; i < argc; i += 2)
{
if (i + 1 >= argc)
{
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"value for \"", argv[i], "\" missing",
(char *) NULL);
return TCL_ERROR;
}
if (strcmp (argv[i], "-parent") == 0)
{
parent = Tk_NameToWindow (interp, argv[i + 1],
Tk_MainWindow (interp));
if (parent == NULL)
return TCL_ERROR;
}
else
{
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"unknown option \"", argv[i], "\"",
(char *) NULL);
return TCL_ERROR;
}
}
if (wd->page_setup != NULL)
psd = *wd->page_setup;
else
{
memset (&psd, 0, sizeof (PAGESETUPDLG));
psd.lStructSize = sizeof (PAGESETUPDLG);
psd.Flags = PSD_DEFAULTMINMARGINS;
}
if (Tk_WindowId (parent) == None)
Tk_MakeWindowExist (parent);
psd.hwndOwner = Tk_GetHWND (Tk_WindowId (parent));
mode = Tcl_SetServiceMode (TCL_SERVICE_ALL);
ret = PageSetupDlg (&psd);
(void) Tcl_SetServiceMode (mode);
if (! ret)
{
DWORD code;
code = CommDlgExtendedError ();
if (code == 0)
{
/* The user pressed cancel. */
return TCL_OK;
}
else
{
char buf[20];
sprintf (buf, "0x%lx", (unsigned long) code);
Tcl_ResetResult (interp);
Tcl_AppendStringsToObj (Tcl_GetObjResult (interp),
"Windows common dialog error ", buf,
(char *) NULL);
return TCL_ERROR;
}
}
if (wd->page_setup == NULL)
wd->page_setup = (PAGESETUPDLG *) ckalloc (sizeof (PAGESETUPDLG));
*wd->page_setup = psd;
return TCL_OK;
}
