static int
TestExceptionCmd(
ClientData dummy, /* Unused */
Tcl_Interp* interp, /* Tcl interpreter */
int objc, /* Argument count */
Tcl_Obj *const objv[]) /* Argument vector */
{
static const char *cmds[] = {
"access_violation", "datatype_misalignment", "array_bounds",
"float_denormal", "float_divbyzero", "float_inexact",
"float_invalidop", "float_overflow", "float_stack", "float_underflow",
"int_divbyzero", "int_overflow", "private_instruction", "inpageerror",
"illegal_instruction", "noncontinue", "stack_overflow",
"invalid_disp", "guard_page", "invalid_handle", "ctrl+c",
NULL
};
static const DWORD exceptions[] = {
EXCEPTION_ACCESS_VIOLATION, EXCEPTION_DATATYPE_MISALIGNMENT,
EXCEPTION_ARRAY_BOUNDS_EXCEEDED, EXCEPTION_FLT_DENORMAL_OPERAND,
EXCEPTION_FLT_DIVIDE_BY_ZERO, EXCEPTION_FLT_INEXACT_RESULT,
EXCEPTION_FLT_INVALID_OPERATION, EXCEPTION_FLT_OVERFLOW,
EXCEPTION_FLT_STACK_CHECK, EXCEPTION_FLT_UNDERFLOW,
EXCEPTION_INT_DIVIDE_BY_ZERO, EXCEPTION_INT_OVERFLOW,
EXCEPTION_PRIV_INSTRUCTION, EXCEPTION_IN_PAGE_ERROR,
EXCEPTION_ILLEGAL_INSTRUCTION, EXCEPTION_NONCONTINUABLE_EXCEPTION,
EXCEPTION_STACK_OVERFLOW, EXCEPTION_INVALID_DISPOSITION,
EXCEPTION_GUARD_PAGE, EXCEPTION_INVALID_HANDLE, CONTROL_C_EXIT
};
int cmd;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 0, objv, "<type-of-exception>");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], cmds, "command", 0,
&cmd) != TCL_OK) {
return TCL_ERROR;
}
/*
* Make sure the GPF dialog doesn't popup.
*/
SetErrorMode(SEM_FAILCRITICALERRORS | SEM_NOGPFAULTERRORBOX);
/*
* As Tcl does not handle structured exceptions, this falls all the way
* back up the instruction stack to the C run-time portion that called
* main() where the process will now be terminated with this exception
* code by the default handler the C run-time provides.
*/
/* SMASH! */
RaiseException(exceptions[cmd], EXCEPTION_NONCONTINUABLE, 0, NULL);
/* NOTREACHED */
return TCL_OK;
}
//
// Convert a type name to a quote type
//
CTABLE_INTERNAL int ctable_parseQuoteType(Tcl_Interp *interp, Tcl_Obj *obj)
{
int index;
if (Tcl_GetIndexFromObj (interp, obj, ctable_quote_names, "type", TCL_EXACT, &index) != TCL_OK)
return -1;
else
return ctable_quote_types[index];
}
int
Tk_GetReliefFromObj(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *objPtr, /* The object we are trying to get the value
* from. */
int *resultPtr) /* Where to place the answer. */
{
return Tcl_GetIndexFromObj(interp, objPtr, reliefStrings, "relief", 0,
resultPtr);
}
static int menuBarFunc( ClientData data, Tcl_Interp *interp,
int objc, Tcl_Obj * const objv[] )
{
static const char *cmds[] = { "delete", "configure",
"add", "addBegin", "addEnd", NULL };
enum cmdIdx { DeleteIdx, ConfigureIdx, AddIdx, BeginIdx, EndIdx };
GtkMenuBar *menuBar = GTK_MENU_BAR( data );
int idx;
if( objc < 2 )
{
Tcl_WrongNumArgs( interp, 1, objv, "command" );
return TCL_ERROR;
}
if( Tcl_GetIndexFromObj( interp, objv[1], cmds, "command",
TCL_EXACT, &idx ) != TCL_OK )
return TCL_ERROR;
switch( idx )
{
case DeleteIdx:
return gnoclDelete( interp, GTK_WIDGET( menuBar ), objc, objv );
case ConfigureIdx:
{
int ret = TCL_ERROR;
if( gnoclParseAndSetOptions( interp, objc - 1, objv + 1,
menuBarOptions, G_OBJECT( menuBar ) ) == TCL_OK )
{
ret = configure( interp, menuBar, menuBarOptions );
}
gnoclClearOptions( menuBarOptions );
return ret;
}
break;
case AddIdx:
case BeginIdx:
case EndIdx:
{
if( objc != 3 )
{
Tcl_WrongNumArgs( interp, 2, objv, "widget-list" );
return TCL_ERROR;
}
return gnoclMenuShellAddChildren( interp,
GTK_MENU_SHELL( menuBar ), objv[2], idx != EndIdx );
}
}
return TCL_OK;
}
/* ARGSUSED */
int
Tcl_SeekObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan; /* The channel to tell on. */
Tcl_WideInt offset; /* Where to seek? */
int mode; /* How to seek? */
Tcl_WideInt result; /* Of calling Tcl_Seek. */
int optionIndex;
static const char *originOptions[] = {
"start", "current", "end", NULL
};
static int modeArray[] = {SEEK_SET, SEEK_CUR, SEEK_END};
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "channelId offset ?origin?");
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[1], &chan, NULL, 0) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetWideIntFromObj(interp, objv[2], &offset) != TCL_OK) {
return TCL_ERROR;
}
mode = SEEK_SET;
if (objc == 4) {
if (Tcl_GetIndexFromObj(interp, objv[3], originOptions, "origin", 0,
&optionIndex) != TCL_OK) {
return TCL_ERROR;
}
mode = modeArray[optionIndex];
}
result = Tcl_Seek(chan, offset, mode);
if (result == Tcl_LongAsWide(-1)) {
/*
* 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_AppendResult(interp, "error during seek on \"",
TclGetString(objv[1]), "\": ",
Tcl_PosixError(interp), NULL);
}
return TCL_ERROR;
}
return TCL_OK;
}
/* $pw identify ?what? $x $y --
* Return index of sash at $x,$y
*/
static int PanedIdentifyCommand(
void *recordPtr, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[])
{
const char *whatTable[] = { "element", "sash", NULL };
enum { IDENTIFY_ELEMENT, IDENTIFY_SASH };
int what = IDENTIFY_SASH;
Paned *pw = recordPtr;
int sashThickness = pw->paned.sashThickness;
int nSashes = Ttk_NumberSlaves(pw->paned.mgr) - 1;
int x, y, pos;
int index;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 2,objv, "?what? x y");
return TCL_ERROR;
}
if ( Tcl_GetIntFromObj(interp, objv[objc-2], &x) != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[objc-1], &y) != TCL_OK
|| (objc == 5 &&
Tcl_GetIndexFromObj(interp, objv[2], whatTable, "option", 0, &what)
!= TCL_OK)
) {
return TCL_ERROR;
}
pos = pw->paned.orient == TTK_ORIENT_HORIZONTAL ? x : y;
for (index = 0; index < nSashes; ++index) {
Pane *pane = Ttk_SlaveData(pw->paned.mgr, index);
if (pane->sashPos <= pos && pos <= pane->sashPos + sashThickness) {
/* Found it. */
switch (what) {
case IDENTIFY_SASH:
Tcl_SetObjResult(interp, Tcl_NewIntObj(index));
return TCL_OK;
case IDENTIFY_ELEMENT:
{
Ttk_Element element =
Ttk_IdentifyElement(SashLayout(pw, index), x, y);
if (element) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj(Ttk_ElementName(element), -1));
}
return TCL_OK;
}
}
}
}
return TCL_OK; /* nothing found - return empty string */
}
/*
*----------------------------------------------------------------------
* AsmInstructionArgvSet --
*
* Set argument to be passed to an instruction of the assemble
* code.
*
*----------------------------------------------------------------------
*/
static void
AsmInstructionArgvSet(Tcl_Interp *interp, int from, int to, int currentArg,
AsmInstruction *inst, AsmCompiledProc *asmProc,
Tcl_Obj **wordOv, int verbose) {
int j;
for (j = from; j < to; j += 2, currentArg++) {
int argIndex, intValue;
Tcl_GetIndexFromObj(interp, wordOv[j], asmStatementArgType, "asm cmd arg type", 0, &argIndex);
Tcl_GetIntFromObj(interp, wordOv[j+1], &intValue);
if (verbose != 0) {
fprintf(stderr, "AsmInstructionArgvSet (type %d) arg[%d] := %s[%s]\n",
argIndex, currentArg, ObjStr(wordOv[j]), ObjStr(wordOv[j+1]));
}
switch (argIndex) {
case asmStatementArgTypeObjIdx:
inst->argv[currentArg] = asmProc->slots[intValue];
break;
case asmStatementArgTypeArgIdx:
AsmArgSet(asmProc, intValue, &inst->argv[currentArg]);
break;
case asmStatementArgTypeResultIdx:
inst->argv[currentArg] = NULL;
break;
case asmStatementArgTypeSlotIdx:
case asmStatementArgTypeInstructionIdx:
case asmStatementArgTypeIntIdx:
inst->argv[currentArg] = INT2PTR(intValue);
break;
case asmStatementArgTypeVarIdx:
fprintf(stderr, ".... var set [%d] = %s\n", currentArg, ObjStr(wordOv[j+1]));
inst->argv[currentArg] = wordOv[j+1];
Tcl_IncrRefCount(inst->argv[currentArg]); // TODO: DECR missing
break;
}
/*fprintf(stderr, "[%d] inst %p name %s arg[%d] %s\n", currentAsmInstruction,
inst, ObjStr(inst->argv[0]), currentArg,
inst->argv[currentArg] ? ObjStr(inst->argv[currentArg]) : "NULL");*/
}
}
/* Object command for a PV object */
static int InstanceCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj * const objv[]) {
pvInfo *info = (pvInfo *) clientData;
if (objc<2) {
Tcl_WrongNumArgs(interp, 1, objv, "subcommand");
return TCL_ERROR;
}
Tcl_Obj *subcommand=objv[1];
int cmdindex;
if (Tcl_GetIndexFromObj(interp, subcommand, pvcmdtable, "subcommand", 0, &cmdindex) != TCL_OK) {
return TCL_ERROR;
}
switch (cmdindex) {
case PUT:
return PutCmd(interp, info, objc, objv);
case GET:
return GetCmd(interp, info, objc, objv);
case MONITOR:
return MonitorCmd(interp, info, objc, objv);
case NAME:
Tcl_SetObjResult(interp, Tcl_NewStringObj(info->name, -1));
return TCL_OK;
case CONNECTED:
Tcl_SetObjResult(interp, Tcl_NewBooleanObj(info->connected));
return TCL_OK;
case NELEM:
Tcl_SetObjResult(interp, Tcl_NewWideIntObj(info->nElem));
return TCL_OK;
case CHID:
Tcl_SetObjResult(interp, Tcl_NewWideIntObj((intptr_t)info->id));
return TCL_OK;
case TYPE:
Tcl_SetObjResult(interp, Tcl_NewStringObj(dbr_type_to_text(info->type), -1));
return TCL_OK;
case DESTROY: {
Tcl_Command self = Tcl_GetCommandFromObj(interp, objv[0]);
if (self != NULL) {
Tcl_DeleteCommandFromToken(interp, self);
}
return TCL_OK;
}
default:
Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown error", -1));
return TCL_ERROR;
}
}
/** \brief create the <B>msgque support</B> subcommand
*
* \tclmsgque_man
*
* \param[in] interp current Tcl interpreter
* \param[in] objc number of objects in \e objv
* \param[in] objv array of \e Tcl_Obj objects
* \return Tcl error-code
*/
static int NS(Support) (
Tcl_Interp * interp,
int objc,
struct Tcl_Obj *const *objv
)
{
int index;
Tcl_Obj *Obj = NULL;
static const char *constant[] = {
"thread", "fork", NULL
};
enum constants {
THREAD, FORK,
};
// read the index
if (objc != 3) {
Tcl_WrongNumArgs (interp, 2, objv, "configuration");
return TCL_ERROR;
}
// get the Index
TclErrorCheck (Tcl_GetIndexFromObj (interp, objv[2], constant, "configuration", 0, &index));
// do the work
switch ((enum constants) index) {
case THREAD:
#if defined(MQ_HAS_THREAD)
Obj = Tcl_NewBooleanObj (1);
#else
Obj = Tcl_NewBooleanObj (0);
#endif
break;
case FORK:
#if defined(HAVE_FORK)
Obj = Tcl_NewBooleanObj (1);
#else
Obj = Tcl_NewBooleanObj (0);
#endif
break;
}
Tcl_SetObjResult (interp, Obj);
return TCL_OK;
}
int
Tk_GetAnchorFromObj(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *objPtr, /* The object we are trying to get the value
* from. */
Tk_Anchor *anchorPtr) /* Where to place the Tk_Anchor that
* corresponds to the string value of
* objPtr. */
{
int index, code;
code = Tcl_GetIndexFromObj(interp, objPtr, anchorStrings, "anchor", 0,
&index);
if (code == TCL_OK) {
*anchorPtr = (Tk_Anchor) index;
}
return code;
}
int
Tk_GetJustifyFromObj(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *objPtr, /* The object we are trying to get the value
* from. */
Tk_Justify *justifyPtr) /* Where to place the Tk_Justify that
* corresponds to the string value of
* objPtr. */
{
int index, code;
code = Tcl_GetIndexFromObj(interp, objPtr, justifyStrings,
"justification", 0, &index);
if (code == TCL_OK) {
*justifyPtr = (Tk_Justify) index;
}
return code;
}
/* ARGSUSED */
static int
ChanPendingObjCmd(
ClientData unused, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel chan;
int index, mode;
static const char *options[] = {"input", "output", NULL};
enum options {PENDING_INPUT, PENDING_OUTPUT};
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "mode channelId");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "mode", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[2], &chan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case PENDING_INPUT:
if ((mode & TCL_READABLE) == 0) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
} else {
Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_InputBuffered(chan)));
}
break;
case PENDING_OUTPUT:
if ((mode & TCL_WRITABLE) == 0) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
} else {
Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_OutputBuffered(chan)));
}
break;
}
return TCL_OK;
}
static int
ImgBmapCmd(
ClientData clientData, /* Information about the image master. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const bmapOptions[] = {"cget", "configure", NULL};
BitmapMaster *masterPtr = clientData;
int index;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], bmapOptions, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case 0: /* cget */
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "option");
return TCL_ERROR;
}
return Tk_ConfigureValue(interp, Tk_MainWindow(interp), configSpecs,
(char *) masterPtr, Tcl_GetString(objv[2]), 0);
case 1: /* configure */
if (objc == 2) {
return Tk_ConfigureInfo(interp, Tk_MainWindow(interp),
configSpecs, (char *) masterPtr, NULL, 0);
} else if (objc == 3) {
return Tk_ConfigureInfo(interp, Tk_MainWindow(interp),
configSpecs, (char *) masterPtr,
Tcl_GetString(objv[2]), 0);
} else {
return ImgBmapConfigureMaster(masterPtr, objc-2, objv+2,
TK_CONFIG_ARGV_ONLY);
}
default:
Tcl_Panic("bad const entries to bmapOptions in ImgBmapCmd");
return TCL_OK;
}
}
int gnoclSessionCmd( ClientData data, Tcl_Interp *interp,
int objc, Tcl_Obj * const objv[] )
{
static const char *cmd[] = { "configure", NULL };
enum optIdx { ConfigureIdx };
int idx;
static GnomeClient *client = NULL;
if( client == NULL )
client = gnome_master_client();
if( client == NULL )
{
Tcl_SetResult( interp, "Unable to initialize session.", TCL_STATIC );
return TCL_ERROR;
}
if( objc < 2 )
{
Tcl_WrongNumArgs( interp, 1, objv, "command" );
return TCL_ERROR;
}
if( Tcl_GetIndexFromObj( interp, objv[1], cmd, "command", TCL_EXACT,
&idx ) != TCL_OK )
return TCL_ERROR;
switch( idx )
{
case ConfigureIdx:
{
int ret = TCL_ERROR;
if( gnoclParseAndSetOptions( interp, objc - 1, objv + 1,
sessionOptions, G_OBJECT( client ) ) == TCL_OK )
{
ret = configure( interp, client, sessionOptions );
}
gnoclClearOptions( sessionOptions );
return ret;
}
break;
}
return TCL_OK;
}
/** \brief create the <B>msgque print</B> subcommand
*
* \tclmsgque_man
*
* \param[in] interp current Tcl interpreter
* \param[in] objc number of objects in \e objv
* \param[in] objv array of \e Tcl_Obj objects
* \return Tcl error-code
*/
static int NS(Print) (
Tcl_Interp * interp,
int objc,
struct Tcl_Obj *const *objv
)
{
int index;
static const char *option[] = {
"object", "objtype", NULL
};
enum options {
OBJECT, OBJECT_TYPE
};
// read the index
if (objc < 3) {
Tcl_WrongNumArgs (interp, 2, objv, "option");
return TCL_ERROR;
}
// get the Index
TclErrorCheck (Tcl_GetIndexFromObj (interp, objv[2], option, "option", 0, &index));
// do the work
switch ((enum options) index) {
case OBJECT:
if (objc != 4) {
Tcl_WrongNumArgs (interp, 4, objv, "tclObj");
return TCL_ERROR;
}
Tcl_SetResult (interp, NS(printObj) ("print", objv[3]), TCL_DYNAMIC);
break;
case OBJECT_TYPE:
if (objc != 4) {
Tcl_WrongNumArgs (interp, 4, objv, "tclObj");
return TCL_ERROR;
}
Tcl_SetResult (interp, NS(printName) (objv[3]), TCL_VOLATILE);
}
return TCL_OK;
}
static int command( Tcl_Interp *interp, int objc, Tcl_Obj * const objv[],
Gnocl_CanvasItemInfo *info )
{
const char *cmds[] = { "appendCoords", NULL };
enum cmdIdx { AppendCoordsIdx };
int idx;
/* canvas itemCommand tag cmd ?-option value? */
if( Tcl_GetIndexFromObj( interp, objv[3], cmds, "command",
TCL_EXACT, &idx ) != TCL_OK )
return TCL_ERROR;
switch( idx )
{
case AppendCoordsIdx:
{
GnomeCanvasPathDef *path;
if( objc != 5 )
{
Tcl_WrongNumArgs( interp, 4, objv, "coords-list" );
return TCL_ERROR;
}
g_object_get( G_OBJECT( info->item), "bpath", &path, NULL );
if( gnoclCanvasAppendPath( interp, objv[4], 0, path )
!= TCL_OK )
return TCL_ERROR;
g_object_set( G_OBJECT( info->item), "bpath", path, NULL );
}
break;
default:
assert( 0 );
return TCL_ERROR;
}
return TCL_OK;
}
/* TtkCheckStateOption --
* Handle -state compatibility option.
*
* NOTE: setting -state disabled / -state enabled affects the
* widget state, but the internal widget state does *not* affect
* the value of the -state option.
* This option is present for compatibility only.
*/
void TtkCheckStateOption(WidgetCore *corePtr, Tcl_Obj *objPtr)
{
int stateOption = TTK_COMPAT_STATE_NORMAL;
unsigned all = TTK_STATE_DISABLED|TTK_STATE_READONLY|TTK_STATE_ACTIVE;
# define SETFLAGS(f) TtkWidgetChangeState(corePtr, f, all^f)
(void)Tcl_GetIndexFromObj(NULL,objPtr,ttkStateStrings,"",0,&stateOption);
switch (stateOption) {
case TTK_COMPAT_STATE_NORMAL:
default:
SETFLAGS(0);
break;
case TTK_COMPAT_STATE_READONLY:
SETFLAGS(TTK_STATE_READONLY);
break;
case TTK_COMPAT_STATE_DISABLED:
SETFLAGS(TTK_STATE_DISABLED);
break;
case TTK_COMPAT_STATE_ACTIVE:
SETFLAGS(TTK_STATE_ACTIVE);
break;
}
# undef SETFLAGS
}
static int
ConsoleObjCmd(
ClientData clientData, /* Access to the console interp */
Tcl_Interp *interp, /* Current interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
int index, result;
static const char *const options[] = {"eval", "hide", "show", "title", NULL};
enum option {CON_EVAL, CON_HIDE, CON_SHOW, CON_TITLE};
Tcl_Obj *cmd = NULL;
ConsoleInfo *info = (ConsoleInfo *) clientData;
Tcl_Interp *consoleInterp = info->consoleInterp;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index)
!= TCL_OK) {
return TCL_ERROR;
}
switch ((enum option) index) {
case CON_EVAL:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script");
return TCL_ERROR;
}
cmd = objv[2];
break;
case CON_HIDE:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
cmd = Tcl_NewStringObj("wm withdraw .", -1);
break;
case CON_SHOW:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
cmd = Tcl_NewStringObj("wm deiconify .", -1);
break;
case CON_TITLE:
if (objc > 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?title?");
return TCL_ERROR;
}
cmd = Tcl_NewStringObj("wm title .", -1);
if (objc == 3) {
Tcl_ListObjAppendElement(NULL, cmd, objv[2]);
}
break;
}
Tcl_IncrRefCount(cmd);
if (consoleInterp && !Tcl_InterpDeleted(consoleInterp)) {
Tcl_Preserve(consoleInterp);
result = Tcl_GlobalEvalObj(consoleInterp, cmd);
Tcl_SetReturnOptions(interp,
Tcl_GetReturnOptions(consoleInterp, result));
Tcl_SetObjResult(interp, Tcl_GetObjResult(consoleInterp));
Tcl_Release(consoleInterp);
} else {
Tcl_AppendResult(interp, "no active console interp", NULL);
result = TCL_ERROR;
}
Tcl_DecrRefCount(cmd);
return result;
}
/** \brief create the <B>msgque get</B> subcommand
*
* \tclmsgque_man
*
* \param[in] interp current Tcl interpreter
* \param[in] objc number of objects in \e objv
* \param[in] objv array of \e Tcl_Obj objects
* \return Tcl error-code
*/
static int NS(Const) (
Tcl_Interp * interp,
int objc,
struct Tcl_Obj *const *objv
)
{
int index;
Tcl_Obj *Obj = NULL;
static const char *constant[] = {
"maxY", "minY", "maxS", "minS", "maxI", "minI", "maxF", "minF", "maxW", "minW", "maxD", "minD", NULL
};
enum constants {
MAXY, MINY, MAXS, MINS, MAXI, MINI, MAXF, MINF, MAXW, MINW, MAXD, MIND,
};
// read the index
if (objc != 3) {
Tcl_WrongNumArgs (interp, 2, objv, "constant");
return TCL_ERROR;
}
// get the Index
TclErrorCheck (Tcl_GetIndexFromObj (interp, objv[2], constant, "constant", 0, &index));
// do the work
switch ((enum constants) index) {
case MAXY:
Obj = Tcl_NewIntObj (SCHAR_MAX);
break;
case MINY:
Obj = Tcl_NewIntObj (SCHAR_MIN);
break;
case MAXS:
Obj = Tcl_NewIntObj (SHRT_MAX);
break;
case MINS:
Obj = Tcl_NewIntObj (SHRT_MIN);
break;
case MAXI:
Obj = Tcl_NewLongObj (INT_MAX);
break;
case MINI:
Obj = Tcl_NewLongObj (INT_MIN);
break;
case MAXF:
Obj = Tcl_NewDoubleObj (FLT_MAX);
break;
case MINF:
Obj = Tcl_NewDoubleObj (FLT_MIN);
break;
case MAXW:
Obj = Tcl_NewWideIntObj (LLONG_MAX);
break;
case MINW:
Obj = Tcl_NewWideIntObj (LLONG_MIN);
break;
case MAXD:
Obj = Tcl_NewDoubleObj (DBL_MAX);
break;
case MIND:
Obj = Tcl_NewDoubleObj (DBL_MIN);
break;
}
Tcl_SetObjResult (interp, Obj);
return TCL_OK;
}
int
Tk_SelectionObjCmd(
ClientData clientData, /* Main window associated with
* interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tk_Window tkwin = clientData;
char *path = NULL;
Atom selection;
char *selName = NULL, *string;
int count, index;
Tcl_Obj **objs;
static const char *const optionStrings[] = {
"clear", "get", "handle", "own", NULL
};
enum options {
SELECTION_CLEAR, SELECTION_GET, SELECTION_HANDLE, SELECTION_OWN
};
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case SELECTION_CLEAR: {
static const char *const clearOptionStrings[] = {
"-displayof", "-selection", NULL
};
enum clearOptions { CLEAR_DISPLAYOF, CLEAR_SELECTION };
int clearIndex;
for (count = objc-2, objs = ((Tcl_Obj **)objv)+2; count > 0;
count-=2, objs+=2) {
string = Tcl_GetString(objs[0]);
if (string[0] != '-') {
break;
}
if (count < 2) {
Tcl_AppendResult(interp, "value for \"", string,
"\" missing", NULL);
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objs[0], clearOptionStrings,
"option", 0, &clearIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum clearOptions) clearIndex) {
case CLEAR_DISPLAYOF:
path = Tcl_GetString(objs[1]);
break;
case CLEAR_SELECTION:
selName = Tcl_GetString(objs[1]);
break;
}
}
if (count == 1) {
path = Tcl_GetString(objs[0]);
} else if (count > 1) {
Tcl_WrongNumArgs(interp, 2, objv, "?-option value ...?");
return TCL_ERROR;
}
if (path != NULL) {
tkwin = Tk_NameToWindow(interp, path, tkwin);
}
if (tkwin == NULL) {
return TCL_ERROR;
}
if (selName != NULL) {
selection = Tk_InternAtom(tkwin, selName);
} else {
selection = XA_PRIMARY;
}
Tk_ClearSelection(tkwin, selection);
break;
}
case SELECTION_GET: {
Atom target;
char *targetName = NULL;
Tcl_DString selBytes;
int result;
static const char *const getOptionStrings[] = {
"-displayof", "-selection", "-type", NULL
};
enum getOptions { GET_DISPLAYOF, GET_SELECTION, GET_TYPE };
int getIndex;
for (count = objc-2, objs = ((Tcl_Obj **)objv)+2; count>0;
count-=2, objs+=2) {
string = Tcl_GetString(objs[0]);
if (string[0] != '-') {
break;
}
if (count < 2) {
Tcl_AppendResult(interp, "value for \"", string,
"\" missing", NULL);
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objs[0], getOptionStrings,
"option", 0, &getIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum getOptions) getIndex) {
case GET_DISPLAYOF:
path = Tcl_GetString(objs[1]);
break;
case GET_SELECTION:
selName = Tcl_GetString(objs[1]);
break;
case GET_TYPE:
targetName = Tcl_GetString(objs[1]);
break;
}
}
if (path != NULL) {
tkwin = Tk_NameToWindow(interp, path, tkwin);
}
if (tkwin == NULL) {
return TCL_ERROR;
}
if (selName != NULL) {
selection = Tk_InternAtom(tkwin, selName);
} else {
selection = XA_PRIMARY;
}
if (count > 1) {
Tcl_WrongNumArgs(interp, 2, objv, "?-option value ...?");
return TCL_ERROR;
} else if (count == 1) {
target = Tk_InternAtom(tkwin, Tcl_GetString(objs[0]));
} else if (targetName != NULL) {
target = Tk_InternAtom(tkwin, targetName);
} else {
target = XA_STRING;
}
Tcl_DStringInit(&selBytes);
result = Tk_GetSelection(interp, tkwin, selection, target,
SelGetProc, &selBytes);
if (result == TCL_OK) {
Tcl_DStringResult(interp, &selBytes);
} else {
Tcl_DStringFree(&selBytes);
}
return result;
}
case SELECTION_HANDLE: {
Atom target, format;
char *targetName = NULL;
char *formatName = NULL;
register CommandInfo *cmdInfoPtr;
int cmdLength;
static const char *const handleOptionStrings[] = {
"-format", "-selection", "-type", NULL
};
enum handleOptions {
HANDLE_FORMAT, HANDLE_SELECTION, HANDLE_TYPE
};
int handleIndex;
for (count = objc-2, objs = ((Tcl_Obj **)objv)+2; count > 0;
count-=2, objs+=2) {
string = Tcl_GetString(objs[0]);
if (string[0] != '-') {
break;
}
if (count < 2) {
Tcl_AppendResult(interp, "value for \"", string,
"\" missing", NULL);
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objs[0],handleOptionStrings,
"option", 0, &handleIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum handleOptions) handleIndex) {
case HANDLE_FORMAT:
formatName = Tcl_GetString(objs[1]);
break;
case HANDLE_SELECTION:
selName = Tcl_GetString(objs[1]);
break;
case HANDLE_TYPE:
targetName = Tcl_GetString(objs[1]);
break;
}
}
if ((count < 2) || (count > 4)) {
Tcl_WrongNumArgs(interp, 2, objv, "?-option value ...? window command");
return TCL_ERROR;
}
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objs[0]), tkwin);
if (tkwin == NULL) {
return TCL_ERROR;
}
if (selName != NULL) {
selection = Tk_InternAtom(tkwin, selName);
} else {
selection = XA_PRIMARY;
}
if (count > 2) {
target = Tk_InternAtom(tkwin, Tcl_GetString(objs[2]));
} else if (targetName != NULL) {
target = Tk_InternAtom(tkwin, targetName);
} else {
target = XA_STRING;
}
if (count > 3) {
format = Tk_InternAtom(tkwin, Tcl_GetString(objs[3]));
} else if (formatName != NULL) {
format = Tk_InternAtom(tkwin, formatName);
} else {
format = XA_STRING;
}
string = Tcl_GetStringFromObj(objs[1], &cmdLength);
if (cmdLength == 0) {
Tk_DeleteSelHandler(tkwin, selection, target);
} else {
cmdInfoPtr = (CommandInfo *) ckalloc((unsigned) (
sizeof(CommandInfo) - 3 + cmdLength));
cmdInfoPtr->interp = interp;
cmdInfoPtr->charOffset = 0;
cmdInfoPtr->byteOffset = 0;
cmdInfoPtr->buffer[0] = '\0';
cmdInfoPtr->cmdLength = cmdLength;
strcpy(cmdInfoPtr->command, string);
Tk_CreateSelHandler(tkwin, selection, target, HandleTclCommand,
cmdInfoPtr, format);
}
return TCL_OK;
}
case SELECTION_OWN: {
register LostCommand *lostPtr;
char *script = NULL;
int cmdLength;
static const char *const ownOptionStrings[] = {
"-command", "-displayof", "-selection", NULL
};
enum ownOptions { OWN_COMMAND, OWN_DISPLAYOF, OWN_SELECTION };
int ownIndex;
for (count = objc-2, objs = ((Tcl_Obj **)objv)+2; count > 0;
count-=2, objs+=2) {
string = Tcl_GetString(objs[0]);
if (string[0] != '-') {
break;
}
if (count < 2) {
Tcl_AppendResult(interp, "value for \"", string,
"\" missing", NULL);
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objs[0], ownOptionStrings,
"option", 0, &ownIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum ownOptions) ownIndex) {
case OWN_COMMAND:
script = Tcl_GetString(objs[1]);
break;
case OWN_DISPLAYOF:
path = Tcl_GetString(objs[1]);
break;
case OWN_SELECTION:
selName = Tcl_GetString(objs[1]);
break;
}
}
if (count > 2) {
Tcl_WrongNumArgs(interp, 2, objv, "?-option value ...? ?window?");
return TCL_ERROR;
}
if (selName != NULL) {
selection = Tk_InternAtom(tkwin, selName);
} else {
selection = XA_PRIMARY;
}
if (count == 0) {
TkSelectionInfo *infoPtr;
TkWindow *winPtr;
if (path != NULL) {
tkwin = Tk_NameToWindow(interp, path, tkwin);
}
if (tkwin == NULL) {
return TCL_ERROR;
}
winPtr = (TkWindow *)tkwin;
for (infoPtr = winPtr->dispPtr->selectionInfoPtr;
infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
if (infoPtr->selection == selection) {
break;
}
}
/*
* Ignore the internal clipboard window.
*/
if ((infoPtr != NULL)
&& (infoPtr->owner != winPtr->dispPtr->clipWindow)) {
Tcl_SetResult(interp, Tk_PathName(infoPtr->owner), TCL_STATIC);
}
return TCL_OK;
}
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objs[0]), tkwin);
if (tkwin == NULL) {
return TCL_ERROR;
}
if (count == 2) {
script = Tcl_GetString(objs[1]);
}
if (script == NULL) {
Tk_OwnSelection(tkwin, selection, NULL, NULL);
return TCL_OK;
}
cmdLength = strlen(script);
lostPtr = (LostCommand *)
ckalloc((unsigned) (sizeof(LostCommand) - 3 + cmdLength));
lostPtr->interp = interp;
strcpy(lostPtr->command, script);
Tk_OwnSelection(tkwin, selection, LostSelection, lostPtr);
return TCL_OK;
}
}
return TCL_OK;
}
/* ARGSUSED */
int
Tk_GrabObjCmd(
ClientData clientData, /* Main window associated with interpreter. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int globalGrab;
Tk_Window tkwin;
TkDisplay *dispPtr;
const char *arg;
int index;
int len;
static const char *const optionStrings[] = {
"current", "release", "set", "status", NULL
};
static const char *const flagStrings[] = {
"-global", NULL
};
enum options {
GRABCMD_CURRENT, GRABCMD_RELEASE, GRABCMD_SET, GRABCMD_STATUS
};
if (objc < 2) {
/*
* Can't use Tcl_WrongNumArgs here because we want the message to
* read:
* wrong # args: should be "cmd ?-global? window" or "cmd option
* ?arg ...?"
* We can fake it with Tcl_WrongNumArgs if we assume the command name
* is "grab", but if it has been aliased, the message will be
* incorrect.
*/
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "wrong # args: should be \"",
Tcl_GetString(objv[0]), " ?-global? window\" or \"",
Tcl_GetString(objv[0]), " option ?arg ...?\"", NULL);
return TCL_ERROR;
}
/*
* First check for a window name or "-global" as the first argument.
*/
arg = Tcl_GetStringFromObj(objv[1], &len);
if (arg[0] == '.') {
/* [grab window] */
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "?-global? window");
return TCL_ERROR;
}
tkwin = Tk_NameToWindow(interp, arg, clientData);
if (tkwin == NULL) {
return TCL_ERROR;
}
return Tk_Grab(interp, tkwin, 0);
} else if (arg[0] == '-' && len > 1) {
if (Tcl_GetIndexFromObj(interp, objv[1], flagStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
/* [grab -global window] */
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?-global? window");
return TCL_ERROR;
}
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), clientData);
if (tkwin == NULL) {
return TCL_ERROR;
}
return Tk_Grab(interp, tkwin, 1);
}
/*
* First argument is not a window name and not "-global", find out which
* option it is.
*/
if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum options) index) {
case GRABCMD_CURRENT:
/* [grab current ?window?] */
if (objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv, "current ?window?");
return TCL_ERROR;
}
if (objc == 3) {
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]),
clientData);
if (tkwin == NULL) {
return TCL_ERROR;
}
dispPtr = ((TkWindow *) tkwin)->dispPtr;
if (dispPtr->eventualGrabWinPtr != NULL) {
Tcl_SetResult(interp, dispPtr->eventualGrabWinPtr->pathName,
TCL_STATIC);
}
} else {
for (dispPtr = TkGetDisplayList(); dispPtr != NULL;
dispPtr = dispPtr->nextPtr) {
if (dispPtr->eventualGrabWinPtr != NULL) {
Tcl_AppendElement(interp,
dispPtr->eventualGrabWinPtr->pathName);
}
}
}
return TCL_OK;
case GRABCMD_RELEASE:
/* [grab release window] */
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "release window");
return TCL_ERROR;
}
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]), clientData);
if (tkwin == NULL) {
Tcl_ResetResult(interp);
} else {
Tk_Ungrab(tkwin);
}
break;
case GRABCMD_SET:
/* [grab set ?-global? window] */
if ((objc != 3) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "set ?-global? window");
return TCL_ERROR;
}
if (objc == 3) {
globalGrab = 0;
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[2]),
clientData);
} else {
globalGrab = 1;
/*
* We could just test the argument by hand instead of using
* Tcl_GetIndexFromObj; the benefit of using the function is that
* it sets up the error message for us, so we are certain to be
* consistant with the rest of Tcl.
*/
if (Tcl_GetIndexFromObj(interp, objv[2], flagStrings, "option",
0, &index) != TCL_OK) {
return TCL_ERROR;
}
tkwin = Tk_NameToWindow(interp, Tcl_GetString(objv[3]),
clientData);
}
if (tkwin == NULL) {
return TCL_ERROR;
}
return Tk_Grab(interp, tkwin, globalGrab);
case GRABCMD_STATUS: {
/* [grab status window] */
TkWindow *winPtr;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "status window");
return TCL_ERROR;
}
winPtr = (TkWindow *) Tk_NameToWindow(interp, Tcl_GetString(objv[2]),
clientData);
if (winPtr == NULL) {
return TCL_ERROR;
}
dispPtr = winPtr->dispPtr;
if (dispPtr->eventualGrabWinPtr != winPtr) {
Tcl_SetResult(interp, "none", TCL_STATIC);
} else if (dispPtr->grabFlags & GRAB_GLOBAL) {
Tcl_SetResult(interp, "global", TCL_STATIC);
} else {
Tcl_SetResult(interp, "local", TCL_STATIC);
}
break;
}
}
return TCL_OK;
}
static int
PrefixMatchObjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int flags = 0, result, index;
int dummyLength, i, errorLength;
Tcl_Obj *errorPtr = NULL;
const char *message = "option";
Tcl_Obj *tablePtr, *objPtr, *resultPtr;
static const char *const matchOptions[] = {
"-error", "-exact", "-message", NULL
};
enum matchOptions {
PRFMATCH_ERROR, PRFMATCH_EXACT, PRFMATCH_MESSAGE
};
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "?options? table string");
return TCL_ERROR;
}
for (i = 1; i < (objc - 2); i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], matchOptions, "option", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum matchOptions) index) {
case PRFMATCH_EXACT:
flags |= TCL_EXACT;
break;
case PRFMATCH_MESSAGE:
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value for -message", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
i++;
message = Tcl_GetString(objv[i]);
break;
case PRFMATCH_ERROR:
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing value for -error", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
return TCL_ERROR;
}
i++;
result = Tcl_ListObjLength(interp, objv[i], &errorLength);
if (result != TCL_OK) {
return TCL_ERROR;
}
if ((errorLength % 2) != 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"error options must have an even number of elements",
-1));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
return TCL_ERROR;
}
errorPtr = objv[i];
break;
}
}
tablePtr = objv[objc - 2];
objPtr = objv[objc - 1];
/*
* Check that table is a valid list first, since we want to handle that
* error case regardless of level.
*/
result = Tcl_ListObjLength(interp, tablePtr, &dummyLength);
if (result != TCL_OK) {
return result;
}
result = GetIndexFromObjList(interp, objPtr, tablePtr, message, flags,
&index);
if (result != TCL_OK) {
if (errorPtr != NULL && errorLength == 0) {
Tcl_ResetResult(interp);
return TCL_OK;
} else if (errorPtr == NULL) {
return TCL_ERROR;
}
if (Tcl_IsShared(errorPtr)) {
errorPtr = Tcl_DuplicateObj(errorPtr);
}
Tcl_ListObjAppendElement(interp, errorPtr,
Tcl_NewStringObj("-code", 5));
Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewIntObj(result));
return Tcl_SetReturnOptions(interp, errorPtr);
}
result = Tcl_ListObjIndex(interp, tablePtr, index, &resultPtr);
if (result != TCL_OK) {
return result;
}
Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
/*************************************************************************
* FUNCTION : RPMPRoblem_ObjL::Problem *
* ARGUMENTS : interp, tcl args, *
* Problem object *
* index in objv of first tag we need *
* RETURNS : 0 if OK, else error *
* EXCEPTIONS : none *
* PURPOSE : Manipulate a problem entry *
* NOTES : format for this is *
* RPM [<prob>] [part [value]]* *
* where <prob> is an existing problem object - if not given, then the *
* command will create a new problem object. *
* [part] is one of the defined problem tags for a problem *
* [value] if given will set the defined part *
* *
* *
*************************************************************************/
int RPMPRoblem_Obj::Problem(Tcl_Interp *interp,int objc, Tcl_Obj *const objv[],
Tcl_Obj *prob,int first_tag
)
{
// Now, we have one of 2 possibilities here - they gave us a single tag
// to query, or a list of (tag,value) pairs
if (objc == (first_tag+1))
{
// Single tag - return the value of the tag.
int which = 0;
if (Tcl_GetIndexFromObj(interp,objv[first_tag],prob_parts,"tag",0,&which) != TCL_OK)
return TCL_ERROR;
Tcl_SetObjResult(interp,Get_part((PARTS)which)); // Return value to TCL
return TCL_OK;
}
Tcl_InvalidateStringRep(prob);
// OK, so this should be a set of (tag,value) pairs - parse them
for (int i = first_tag; i < objc; i += 2)
{
// Make sure we actually HAVE a value
if ((i+1)>objc)
return Cmd_base::Error(interp,"Need a value");
// what tag is it?
int which = 0;
if (Tcl_GetIndexFromObj(interp,objv[i],prob_parts,"tag",0,&which) != TCL_OK)
return TCL_ERROR;
switch ((PARTS)which)
{
case PACKAGE:
{
int len = 0;
char *x = Tcl_GetStringFromObj(objv[i+1],&len);
char *p = new char[len+1];
strncpy(p,x,len);
p[len] = 0;
if (problem.pkgNEVR)
delete [] problem.pkgNEVR;
problem.pkgNEVR = p;
}
break;
case ALT:
{
int len = 0;
char *x = Tcl_GetStringFromObj(objv[i+1],&len);
char *p = new char[len+1];
strncpy(p,x,len);
p[len] = 0;
if (problem.altNEVR)
delete [] problem.altNEVR;
problem.altNEVR = p;
}
break;
case KEY:
{
int value = 0;
if (Tcl_GetIntFromObj(interp,objv[i+1],&value) != TCL_OK)
return TCL_ERROR;
problem.key = (fnpyKey)value;
}
break;
case TYPE:
{
int which = 0;
if (Tcl_GetIndexFromObjStruct(interp,objv[i+1],(char **)&prob_strings[0].name,sizeof(prob_strings[0]),
"type",0,&which
) != TCL_OK)
return TCL_ERROR;
problem.type = (rpmProblemType)prob_strings[which].code;
}
break;
case IGNORE:
{
int value = 0;
if (Tcl_GetIntFromObj(interp,objv[i+1],&value) != TCL_OK)
return TCL_ERROR;
problem.ignoreProblem = value;
}
break;
case STRING:
{
int len = 0;
char *x = Tcl_GetStringFromObj(objv[i+1],&len);
char *p = new char[len+1];
strncpy(p,x,len);
p[len] = 0;
if (problem.str1)
delete [] problem.str1;
problem.str1 = p;
}
break;
case INT:
{
int value = 0;
if (Tcl_GetIntFromObj(interp,objv[i+1],&value) != TCL_OK)
return TCL_ERROR;
problem.ulong1 = value;
}
break;
}
}
Tcl_SetObjResult(interp,prob); // Return value to TCL
return TCL_OK;
}
/* 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;
}
/**
/brief
/author William J Giddings
/date 2008-08
**/
int drawingAreaFunc ( ClientData data, Tcl_Interp *interp, int objc, Tcl_Obj * const objv[] )
{
#ifdef DEBUG_DRAWING_AREA
g_printf ( "drawingAreaFunc\n" );
gint _i;
for ( _i = 0; _i < objc; _i++ )
{
g_printf ( "\targ %d = %s\n", _i, Tcl_GetString ( objv[_i] ) );
}
#endif
static const char *cmds[] =
{
"draw", "cget", "configure", "delete", "class", "erase", "option", NULL
};
enum cmdIdx
{
DrawIdx, CgetIdx, ConfigureIdx, DeleteIdx, ClassIdx, EraseIdx, OptionIdx
};
/* relocate these to relevant parts of the souce file */
static const char *drawOpts[] =
{
"point", "points", "line", "lines", "pixbuf", "segments",
"rectangle", "arc", "polygon", "trapezoids", "glyph",
"glyphTransformed", "layoutLine", "layoutWithColors",
"string", "text", "image",
NULL
};
enum drawOptsIdx
{
PointIdx, PointsIdx, LineIdx, LinesIdx, PixbufIdx, SegmentsIdx,
RectangleIdx, ArcIdx, PolygonIdx, TrapezoidsIdx, GlypIdx,
GlyphTransformedIdx, LayoutLineIdx, LayoutWithColorsIdx,
StringIdx, TextIdx, ImageIdx
};
/*
static const char *events[] =
{
"expose", "motion", "motionHint",
"buttonMotion", "button1Motion", "button2Motion",
"button3Motion", "buttonPress", "buttonRelease",
"keyPress", "keyRelease", "enter",
"leave", "focus", "structure",
"propertyChange", "visibility", "proximityIn",
"proximityOut", "substructure", "scroll",
"all", NULL
};
*/
GtkWidget *area = GTK_WIDGET ( data );
int idx;
int idx2;
if ( objc < 2 )
{
Tcl_WrongNumArgs ( interp, 1, objv, "command" );
return TCL_ERROR;
}
if ( Tcl_GetIndexFromObj ( interp, objv[1], cmds, "command", TCL_EXACT, &idx ) != TCL_OK )
{
return TCL_ERROR;
}
switch ( idx )
{
case OptionIdx:
{
#ifdef DEBUG_DRAWING_AREA
g_print ( "drawingArea OptionIdx\n" );
#endif
/*
other options here could include:
remove -remove the option from the options array (incl. script)
available -return a list of currently configured options
suspend -remove option from the event mask only
resume -add the option to the event mask
*/
if ( !strcmp ( Tcl_GetString ( objv[2] ), "add" ) )
{
g_printf ( " add\n" );
}
else
{
return TCL_ERROR;
}
/* create a hash table for events and handlers */
int OptIdx;
if ( Tcl_GetIndexFromObj ( interp, objv[3], options, "option", TCL_EXACT, &OptIdx ) != TCL_OK )
{
return TCL_ERROR;
}
_n = doOptionAdd ( interp, area, OptIdx );
break;
case ConfigureIdx:
{
#ifdef DEBUG_DRAWING_AREA
g_print ( "drawingArea ConfigureIdx\n" );
#endif
int ret = TCL_ERROR;
if ( gnoclParseAndSetOptions ( interp, objc - 1, objv + 1,
drawingAreaOptions, area ) == TCL_OK )
{
ret = configure ( interp, area, drawingAreaOptions );
}
gnoclClearOptions ( drawingAreaOptions );
return ret;
}
break;
case DeleteIdx:
{
g_print ( "delete\n" );
}
break;
case ClassIdx:
{
g_print ( "Class = drawingArea\n" );
Tcl_SetObjResult ( interp, Tcl_NewStringObj ( "drawingArea", -1 ) );
}
break;
/*
case PointIdx
case PointsIdx
case LineIdx
case LinesIdx
case PixbufIdx
case SegmentsIdx
case RectangleIdx
case ArcIdx
case PolygonIdx
case TrapezoidsIdx
case GlypIdx
case GlyphTransformedIdx
case LayoutLineIdx
case LayoutWithColorsIdx,
case StringIdx
case TextIdx
case ImageIdx
*/
}
}
return TCL_OK;
}
int
Tk_SendObjCmd(
ClientData clientData, /* Information about sender (only dispPtr
* field is used). */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
enum {
SEND_ASYNC, SEND_DISPLAYOF, SEND_LAST
};
static const char *sendOptions[] = {
"-async", "-displayof", "--", NULL
};
int result = TCL_OK;
int i, optind, async = 0;
Tcl_Obj *displayPtr = NULL;
/*
* Process the command options.
*/
for (i = 1; i < objc; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], sendOptions,
"option", 0, &optind) != TCL_OK) {
break;
}
if (optind == SEND_ASYNC) {
++async;
} else if (optind == SEND_DISPLAYOF) {
displayPtr = objv[++i];
} else if (optind == SEND_LAST) {
i++;
break;
}
}
/*
* Ensure we still have a valid command.
*/
if ((objc - i) < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-async? ?-displayof? ?--? interpName arg ?arg ...?");
result = TCL_ERROR;
}
/*
* We don't support displayPtr. See TIP #150.
*/
if (displayPtr) {
Tcl_SetStringObj(Tcl_GetObjResult(interp),
"option not implemented: \"displayof\" is not available "
"for this platform.", -1);
result = TCL_ERROR;
}
/*
* Send the arguments to the foreign interp.
*/
/* FIX ME: we need to check for local interp */
if (result == TCL_OK) {
LPDISPATCH pdisp;
result = FindInterpreterObject(interp, Tcl_GetString(objv[i]), &pdisp);
if (result == TCL_OK) {
i++;
result = Send(pdisp, interp, async, clientData, objc-i, objv+i);
pdisp->lpVtbl->Release(pdisp);
}
}
return result;
}
int
Tcl_FcopyObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_Channel inChan, outChan;
int mode, i, toRead, index;
Tcl_Obj *cmdPtr;
static const char* switches[] = { "-size", "-command", NULL };
enum { FcopySize, FcopyCommand };
if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) {
Tcl_WrongNumArgs(interp, 1, objv,
"input output ?-size size? ?-command callback?");
return TCL_ERROR;
}
/*
* Parse the channel arguments and verify that they are readable or
* writable, as appropriate.
*/
if (TclGetChannelFromObj(interp, objv[1], &inChan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
Tcl_AppendResult(interp, "channel \"", TclGetString(objv[1]),
"\" wasn't opened for reading", NULL);
return TCL_ERROR;
}
if (TclGetChannelFromObj(interp, objv[2], &outChan, &mode, 0) != TCL_OK) {
return TCL_ERROR;
}
if ((mode & TCL_WRITABLE) == 0) {
Tcl_AppendResult(interp, "channel \"", TclGetString(objv[2]),
"\" wasn't opened for writing", NULL);
return TCL_ERROR;
}
toRead = -1;
cmdPtr = NULL;
for (i = 3; i < objc; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], switches, "switch", 0,
&index) != TCL_OK) {
return TCL_ERROR;
}
switch (index) {
case FcopySize:
if (TclGetIntFromObj(interp, objv[i+1], &toRead) != TCL_OK) {
return TCL_ERROR;
}
if (toRead<0) {
/*
* Handle all negative sizes like -1, meaning 'copy all'. By
* resetting toRead we avoid changes in the core copying
* functions (which explicitly check for -1 and crash on any
* other negative value).
*/
toRead = -1;
}
break;
case FcopyCommand:
cmdPtr = objv[i+1];
break;
}
}
return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr);
}
int
TkTextMarkCmd(
register TkText *textPtr, /* Information about text widget. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. Someone else has already
* parsed this command enough to know that
* objv[1] is "mark". */
{
Tcl_HashEntry *hPtr;
TkTextSegment *markPtr;
Tcl_HashSearch search;
TkTextIndex index;
const Tk_SegType *newTypePtr;
int optionIndex;
static const char *markOptionStrings[] = {
"gravity", "names", "next", "previous", "set", "unset", NULL
};
enum markOptions {
MARK_GRAVITY, MARK_NAMES, MARK_NEXT, MARK_PREVIOUS, MARK_SET,
MARK_UNSET
};
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[2], markOptionStrings, "mark option",
0, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum markOptions) optionIndex) {
case MARK_GRAVITY: {
char c;
int length;
char *str;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 3, objv, "markName ?gravity?");
return TCL_ERROR;
}
str = Tcl_GetStringFromObj(objv[3],&length);
if (length == 6 && !strcmp(str, "insert")) {
markPtr = textPtr->insertMarkPtr;
} else if (length == 7 && !strcmp(str, "current")) {
markPtr = textPtr->currentMarkPtr;
} else {
hPtr = Tcl_FindHashEntry(&textPtr->sharedTextPtr->markTable, str);
if (hPtr == NULL) {
Tcl_AppendResult(interp, "there is no mark named \"",
Tcl_GetString(objv[3]), "\"", NULL);
return TCL_ERROR;
}
markPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr);
}
if (objc == 4) {
if (markPtr->typePtr == &tkTextRightMarkType) {
Tcl_SetResult(interp, "right", TCL_STATIC);
} else {
Tcl_SetResult(interp, "left", TCL_STATIC);
}
return TCL_OK;
}
str = Tcl_GetStringFromObj(objv[4],&length);
c = str[0];
if ((c == 'l') && (strncmp(str, "left", (unsigned)length) == 0)) {
newTypePtr = &tkTextLeftMarkType;
} else if ((c == 'r') &&
(strncmp(str, "right", (unsigned)length) == 0)) {
newTypePtr = &tkTextRightMarkType;
} else {
Tcl_AppendResult(interp, "bad mark gravity \"", str,
"\": must be left or right", NULL);
return TCL_ERROR;
}
TkTextMarkSegToIndex(textPtr, markPtr, &index);
TkBTreeUnlinkSegment(markPtr, markPtr->body.mark.linePtr);
markPtr->typePtr = newTypePtr;
TkBTreeLinkSegment(markPtr, &index);
break;
}
case MARK_NAMES:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 3, objv, NULL);
return TCL_ERROR;
}
Tcl_AppendElement(interp, "insert");
Tcl_AppendElement(interp, "current");
for (hPtr = Tcl_FirstHashEntry(&textPtr->sharedTextPtr->markTable,
&search); hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
Tcl_AppendElement(interp,
Tcl_GetHashKey(&textPtr->sharedTextPtr->markTable, hPtr));
}
break;
case MARK_NEXT:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "index");
return TCL_ERROR;
}
return MarkFindNext(interp, textPtr, Tcl_GetString(objv[3]));
case MARK_PREVIOUS:
if (objc != 4) {
Tcl_WrongNumArgs(interp, 3, objv, "index");
return TCL_ERROR;
}
return MarkFindPrev(interp, textPtr, Tcl_GetString(objv[3]));
case MARK_SET:
if (objc != 5) {
Tcl_WrongNumArgs(interp, 3, objv, "markName index");
return TCL_ERROR;
}
if (TkTextGetObjIndex(interp, textPtr, objv[4], &index) != TCL_OK) {
return TCL_ERROR;
}
TkTextSetMark(textPtr, Tcl_GetString(objv[3]), &index);
return TCL_OK;
case MARK_UNSET: {
int i;
for (i = 3; i < objc; i++) {
hPtr = Tcl_FindHashEntry(&textPtr->sharedTextPtr->markTable,
Tcl_GetString(objv[i]));
if (hPtr != NULL) {
markPtr = (TkTextSegment *) Tcl_GetHashValue(hPtr);
/*
* Special case not needed with peer widgets.
*/
if ((markPtr == textPtr->insertMarkPtr)
|| (markPtr == textPtr->currentMarkPtr)) {
continue;
}
TkBTreeUnlinkSegment(markPtr, markPtr->body.mark.linePtr);
Tcl_DeleteHashEntry(hPtr);
ckfree((char *) markPtr);
}
}
break;
}
}
return TCL_OK;
}
/* ARGSUSED */
int
Tcl_AfterObjCmd(
ClientData clientData, /* Unused */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_WideInt ms = 0; /* Number of milliseconds to wait */
Tcl_Time wakeup;
AfterInfo *afterPtr;
AfterAssocData *assocPtr;
int length;
int index;
static const char *const afterSubCmds[] = {
"cancel", "idle", "info", NULL
};
enum afterSubCmds {AFTER_CANCEL, AFTER_IDLE, AFTER_INFO};
ThreadSpecificData *tsdPtr = InitTimer();
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
/*
* Create the "after" information associated for this interpreter, if it
* doesn't already exist.
*/
assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL);
if (assocPtr == NULL) {
assocPtr = ckalloc(sizeof(AfterAssocData));
assocPtr->interp = interp;
assocPtr->firstAfterPtr = NULL;
Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr);
}
/*
* First lets see if the command was passed a number as the first argument.
*/
if (objv[1]->typePtr == &tclIntType
#ifndef TCL_WIDE_INT_IS_LONG
|| objv[1]->typePtr == &tclWideIntType
#endif
|| objv[1]->typePtr == &tclBignumType
|| (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0,
&index) != TCL_OK)) {
index = -1;
if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
const char *arg = Tcl_GetString(objv[1]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad argument \"%s\": must be"
" cancel, idle, info, or an integer", arg));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
arg, NULL);
return TCL_ERROR;
}
}
/*
* At this point, either index = -1 and ms contains the number of ms
* to wait, or else index is the index of a subcommand.
*/
switch (index) {
case -1: {
if (ms < 0) {
ms = 0;
}
if (objc == 2) {
return AfterDelay(interp, ms);
}
afterPtr = ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
/*
* The variable below is used to generate unique identifiers for after
* commands. This id can wrap around, which can potentially cause
* problems. However, there are not likely to be problems in practice,
* because after commands can only be requested to about a month in
* the future, and wrap-around is unlikely to occur in less than about
* 1-10 years. Thus it's unlikely that any old ids will still be
* around when wrap-around occurs.
*/
afterPtr->id = tsdPtr->afterId;
tsdPtr->afterId += 1;
Tcl_GetTime(&wakeup);
wakeup.sec += (long)(ms / 1000);
wakeup.usec += ((long)(ms % 1000)) * 1000;
if (wakeup.usec > 1000000) {
wakeup.sec++;
wakeup.usec -= 1000000;
}
afterPtr->token = TclCreateAbsoluteTimerHandler(&wakeup,
AfterProc, afterPtr);
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
return TCL_OK;
}
case AFTER_CANCEL: {
Tcl_Obj *commandPtr;
const char *command, *tempCommand;
int tempLength;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "id|command");
return TCL_ERROR;
}
if (objc == 3) {
commandPtr = objv[2];
} else {
commandPtr = Tcl_ConcatObj(objc-2, objv+2);;
}
command = TclGetStringFromObj(commandPtr, &length);
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
tempCommand = TclGetStringFromObj(afterPtr->commandPtr,
&tempLength);
if ((length == tempLength)
&& !memcmp(command, tempCommand, (unsigned) length)) {
break;
}
}
if (afterPtr == NULL) {
afterPtr = GetAfterEvent(assocPtr, commandPtr);
}
if (objc != 3) {
Tcl_DecrRefCount(commandPtr);
}
if (afterPtr != NULL) {
if (afterPtr->token != NULL) {
Tcl_DeleteTimerHandler(afterPtr->token);
} else {
Tcl_CancelIdleCall(AfterProc, afterPtr);
}
FreeAfterPtr(afterPtr);
}
break;
}
case AFTER_IDLE:
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?");
return TCL_ERROR;
}
afterPtr = ckalloc(sizeof(AfterInfo));
afterPtr->assocPtr = assocPtr;
if (objc == 3) {
afterPtr->commandPtr = objv[2];
} else {
afterPtr->commandPtr = Tcl_ConcatObj(objc-2, objv+2);
}
Tcl_IncrRefCount(afterPtr->commandPtr);
afterPtr->id = tsdPtr->afterId;
tsdPtr->afterId += 1;
afterPtr->token = NULL;
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
Tcl_DoWhenIdle(AfterProc, afterPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
break;
case AFTER_INFO:
if (objc == 2) {
Tcl_Obj *resultObj = Tcl_NewObj();
for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
afterPtr = afterPtr->nextPtr) {
if (assocPtr->interp == interp) {
Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf(
"after#%d", afterPtr->id));
}
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
}
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?id?");
return TCL_ERROR;
}
afterPtr = GetAfterEvent(assocPtr, objv[2]);
if (afterPtr == NULL) {
const char *eventStr = TclGetString(objv[2]);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"event \"%s\" doesn't exist", eventStr));
Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL);
return TCL_ERROR;
} else {
Tcl_Obj *resultListPtr = Tcl_NewObj();
Tcl_ListObjAppendElement(interp, resultListPtr,
afterPtr->commandPtr);
Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
(afterPtr->token == NULL) ? "idle" : "timer", -1));
Tcl_SetObjResult(interp, resultListPtr);
}
break;
default:
Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
}
return TCL_OK;
}
int
Tcl_SocketObjCmd(
ClientData notUsed, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *socketOptions[] = {
"-async", "-myaddr", "-myport","-server", NULL
};
enum socketOptions {
SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER
};
int optionIndex, a, server = 0, port, myport = 0, async = 0;
char *host, *script = NULL, *myaddr = NULL;
Tcl_Channel chan;
if (TclpHasSockets(interp) != TCL_OK) {
return TCL_ERROR;
}
for (a = 1; a < objc; a++) {
const char *arg = Tcl_GetString(objv[a]);
if (arg[0] != '-') {
break;
}
if (Tcl_GetIndexFromObj(interp, objv[a], socketOptions, "option",
TCL_EXACT, &optionIndex) != TCL_OK) {
return TCL_ERROR;
}
switch ((enum socketOptions) optionIndex) {
case SKT_ASYNC:
if (server == 1) {
Tcl_AppendResult(interp,
"cannot set -async option for server sockets", NULL);
return TCL_ERROR;
}
async = 1;
break;
case SKT_MYADDR:
a++;
if (a >= objc) {
Tcl_AppendResult(interp,
"no argument given for -myaddr option", NULL);
return TCL_ERROR;
}
myaddr = TclGetString(objv[a]);
break;
case SKT_MYPORT: {
char *myPortName;
a++;
if (a >= objc) {
Tcl_AppendResult(interp,
"no argument given for -myport option", NULL);
return TCL_ERROR;
}
myPortName = TclGetString(objv[a]);
if (TclSockGetPort(interp, myPortName, "tcp", &myport) != TCL_OK) {
return TCL_ERROR;
}
break;
}
case SKT_SERVER:
if (async == 1) {
Tcl_AppendResult(interp,
"cannot set -async option for server sockets", NULL);
return TCL_ERROR;
}
server = 1;
a++;
if (a >= objc) {
Tcl_AppendResult(interp,
"no argument given for -server option", NULL);
return TCL_ERROR;
}
script = TclGetString(objv[a]);
break;
default:
Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
}
}
if (server) {
host = myaddr; /* NULL implies INADDR_ANY */
if (myport != 0) {
Tcl_AppendResult(interp, "option -myport is not valid for servers",
NULL);
return TCL_ERROR;
}
} else if (a < objc) {
host = TclGetString(objv[a]);
a++;
} else {
Interp *iPtr;
wrongNumArgs:
iPtr = (Interp *) interp;
Tcl_WrongNumArgs(interp, 1, objv,
"?-myaddr addr? ?-myport myport? ?-async? host port");
iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
Tcl_WrongNumArgs(interp, 1, objv,
"-server command ?-myaddr addr? port");
iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS;
return TCL_ERROR;
}
if (a == objc-1) {
if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp",
&port) != TCL_OK) {
return TCL_ERROR;
}
} else {
goto wrongNumArgs;
}
if (server) {
AcceptCallback *acceptCallbackPtr = (AcceptCallback *)
ckalloc((unsigned) sizeof(AcceptCallback));
unsigned len = strlen(script) + 1;
char *copyScript = ckalloc(len);
memcpy(copyScript, script, len);
acceptCallbackPtr->script = copyScript;
acceptCallbackPtr->interp = interp;
chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
acceptCallbackPtr);
if (chan == NULL) {
ckfree(copyScript);
ckfree((char *) acceptCallbackPtr);
return TCL_ERROR;
}
/*
* Register with the interpreter to let us know when the interpreter
* is deleted (by having the callback set the interp field of the
* acceptCallbackPtr's structure to NULL). This is to avoid trying to
* eval the script in a deleted interpreter.
*/
RegisterTcpServerInterpCleanup(interp, acceptCallbackPtr);
/*
* Register a close callback. This callback will inform the
* interpreter (if it still exists) that this channel does not need to
* be informed when the interpreter is deleted.
*/
Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr);
} else {
chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async);
if (chan == NULL) {
return TCL_ERROR;
}
}
Tcl_RegisterChannel(interp, chan);
Tcl_AppendResult(interp, Tcl_GetChannelName(chan), NULL);
return TCL_OK;
}
