Ejemplo n.º 1
0
	/* ARGSUSED */
int
Tcl_ForCmd(
    void *dummy			/* Not used. */
    , Tcl_Interp *interp			/* Current interpreter. */
    , int argc				/* Number of arguments. */
    , unsigned char **argv		/* Argument strings. */
    )
{
    int result, value;

    if (argc != 5) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" start test next command\"", 0);
	return TCL_ERROR;
    }

    result = Tcl_Eval(interp, argv[1], 0, 0);
    if (result != TCL_OK) {
	if (result == TCL_ERROR) {
	    Tcl_AddErrorInfo(interp, (unsigned char*) "\n    (\"for\" initial command)");
	}
	return result;
    }
    while (1) {
	result = Tcl_ExprBoolean(interp, argv[2], &value);
	if (result != TCL_OK) {
	    return result;
	}
	if (!value) {
	    break;
	}
	result = Tcl_Eval(interp, argv[4], 0, 0);
	if (result == TCL_CONTINUE) {
	    result = TCL_OK;
	} else if (result != TCL_OK) {
	    if (result == TCL_ERROR) {
		unsigned char msg[60];
		snprintf(msg, sizeof (msg), "\n    (\"for\" body line %d)", interp->errorLine);
		Tcl_AddErrorInfo(interp, msg);
	    }
	    break;
	}
	result = Tcl_Eval(interp, argv[3], 0, 0);
	if (result == TCL_BREAK) {
	    break;
	} else if (result != TCL_OK) {
	    if (result == TCL_ERROR) {
		Tcl_AddErrorInfo(interp, (unsigned char*) "\n    (\"for\" loop-end command)");
	    }
	    return result;
	}
    }
    if (result == TCL_BREAK) {
	result = TCL_OK;
    }
    if (result == TCL_OK) {
	Tcl_ResetResult(interp);
    }
    return result;
}
Ejemplo n.º 2
0
/*
 *--------------------------------------------------------------
 *
 * mongotcl_setBsonError -- command deletion callback routine.
 *
 * Results:
 *      ...create an error message based on bson object error fields.
 *      ...set errorCode based on the same bson object error fields.
 *
 *      return TCL_ERROR
 *
 *--------------------------------------------------------------
 */
int
mongotcl_setBsonError (Tcl_Interp *interp, bson *bson) {
    Tcl_Obj *list = Tcl_NewObj();
    Tcl_Obj *errorCodeList = Tcl_NewObj();

    if (bson->err & BSON_NOT_UTF8) {
		Tcl_AddErrorInfo (interp, "bson not utf8");
		Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj("NOT_UTF8",-1));
    }

    if (bson->err & BSON_FIELD_HAS_DOT) {
		Tcl_AddErrorInfo (interp, "bson field has dot");
		Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj("HAS_DOT",-1));
    }

    if (bson->err & BSON_FIELD_INIT_DOLLAR) {
		Tcl_AddErrorInfo (interp, "bson field has initial dollar sign");
		Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj("INIT_DOLLAR",-1));
    }

    if (bson->err & BSON_ALREADY_FINISHED) {
		Tcl_SetObjResult (interp, Tcl_NewStringObj ("bson already finished", -1));
		Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj("ALREADY_FINISHED",-1));
    }

	Tcl_ListObjAppendElement(interp, errorCodeList, Tcl_NewStringObj("BSON",-1));
    Tcl_ListObjAppendElement(interp, errorCodeList, list);

    Tcl_SetObjErrorCode (interp, errorCodeList);

    return TCL_ERROR;
}
Ejemplo n.º 3
0
void
gdbtk_interp::pre_command_loop ()
{
  /* We no longer want to use stdin as the command input stream: disable
     events from stdin. */
  main_ui->input_fd = -1;

  if (Tcl_Eval (gdbtk_tcl_interp, "gdbtk_tcl_preloop") != TCL_OK)
    {
      const char *msg;

      /* Force errorInfo to be set up propertly.  */
      Tcl_AddErrorInfo (gdbtk_tcl_interp, "");

      msg = Tcl_GetVar (gdbtk_tcl_interp, "errorInfo", TCL_GLOBAL_ONLY);
#ifdef _WIN32
      MessageBox (NULL, msg, NULL, MB_OK | MB_ICONERROR | MB_TASKMODAL);
#else
      fputs_unfiltered (msg, gdb_stderr);
#endif
    }

#ifdef _WIN32
  close_bfds ();
#endif
}
Ejemplo n.º 4
0
static int
Turbine_Init_Cmd(ClientData cdata, Tcl_Interp *interp,
                 int objc, Tcl_Obj *const objv[])
{
  TCL_ARGS(4);
  int amserver, rank, size;

  get_tcl_version();

  int rc;
  rc = Tcl_GetIntFromObj(interp, objv[1], &amserver);
  TCL_CHECK(rc);
  rc = Tcl_GetIntFromObj(interp, objv[2], &rank);
  TCL_CHECK(rc);
  rc = Tcl_GetIntFromObj(interp, objv[3], &size);
  TCL_CHECK(rc);

  turbine_code code = turbine_init(amserver, rank, size);
  if (code != TURBINE_SUCCESS)
  {
    Tcl_AddErrorInfo(interp, " Could not initialize Turbine!\n");
    return TCL_ERROR;
  }

  log_setup(rank);

  return TCL_OK;
}
Ejemplo n.º 5
0
	/* ARGSUSED */
int
Tcl_ErrorCmd(
    void *dummy			/* Not used. */
    , Tcl_Interp *interp			/* Current interpreter. */
    , int argc				/* Number of arguments. */
    , unsigned char **argv		/* Argument strings. */
    )
{
    Interp *iPtr = (Interp *) interp;

    if ((argc < 2) || (argc > 4)) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" message ?errorInfo? ?errorCode?\"", 0);
	return TCL_ERROR;
    }
    if ((argc >= 3) && (argv[2][0] != 0)) {
	Tcl_AddErrorInfo(interp, argv[2]);
	iPtr->flags |= ERR_ALREADY_LOGGED;
    }
    if (argc == 4) {
	Tcl_SetVar2(interp, (unsigned char*) "errorCode", 0, argv[3],
		TCL_GLOBAL_ONLY);
	iPtr->flags |= ERROR_CODE_SET;
    }
    Tcl_SetResult(interp, argv[1], TCL_VOLATILE);
    return TCL_ERROR;
}
Ejemplo n.º 6
0
static void
gdbtk_command_loop (void)
{
  extern FILE *instream;

  /* We no longer want to use stdin as the command input stream */
  instream = NULL;

  if (Tcl_Eval (gdbtk_interp, "gdbtk_tcl_preloop") != TCL_OK)
    {
      const char *msg;

      /* Force errorInfo to be set up propertly.  */
      Tcl_AddErrorInfo (gdbtk_interp, "");

      msg = Tcl_GetVar (gdbtk_interp, "errorInfo", TCL_GLOBAL_ONLY);
#ifdef _WIN32
      MessageBox (NULL, msg, NULL, MB_OK | MB_ICONERROR | MB_TASKMODAL);
#else
      fputs_unfiltered (msg, gdb_stderr);
#endif
    }

#ifdef _WIN32
  close_bfds ();
#endif

  Tk_MainLoop ();
}
Ejemplo n.º 7
0
void
TkWmProtocolEventProc(
    TkWindow *winPtr,		/* Window to which the event was sent. */
    XEvent *eventPtr)		/* X event. */
{
    WmInfo *wmPtr;
    ProtocolHandler *protPtr;
    Tcl_Interp *interp;
    Atom protocol;
    int result;

    wmPtr = winPtr->wmInfoPtr;
    if (wmPtr == NULL) {
	return;
    }
    protocol = (Atom) eventPtr->xclient.data.l[0];
    for (protPtr = wmPtr->protPtr; protPtr != NULL;
	    protPtr = protPtr->nextPtr) {
	if (protocol == protPtr->protocol) {
	    Tcl_Preserve(protPtr);
	    interp = protPtr->interp;
	    Tcl_Preserve(interp);
	    result = Tcl_EvalEx(interp, protPtr->command, -1, TCL_EVAL_GLOBAL);
	    if (result != TCL_OK) {
		Tcl_AddErrorInfo(interp, "\n    (command for \"");
		Tcl_AddErrorInfo(interp,
			Tk_GetAtomName((Tk_Window) winPtr, protocol));
		Tcl_AddErrorInfo(interp, "\" window manager protocol)");
		Tcl_BackgroundError(interp);
	    }
	    Tcl_Release(interp);
	    Tcl_Release(protPtr);
	    return;
	}
    }

    /*
     * No handler was present for this protocol. If this is a WM_DELETE_WINDOW
     * message then just destroy the window.
     */

    if (protocol == Tk_InternAtom((Tk_Window) winPtr, "WM_DELETE_WINDOW")) {
	Tk_DestroyWindow((Tk_Window) winPtr);
    }
}
Ejemplo n.º 8
0
	/* ARGSUSED */
int
Tcl_ForeachCmd(
    void *dummy			/* Not used. */
    , Tcl_Interp *interp			/* Current interpreter. */
    , int argc				/* Number of arguments. */
    , unsigned char **argv		/* Argument strings. */
    )
{
    int listArgc, i, result;
    unsigned char **listArgv;

    if (argc != 4) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" varName list command\"", 0);
	return TCL_ERROR;
    }

    /*
     * Break the list up into elements, and execute the command once
     * for each value of the element.
     */

    result = Tcl_SplitList(interp, argv[2], &listArgc, &listArgv);
    if (result != TCL_OK) {
	return result;
    }
    for (i = 0; i < listArgc; i++) {
	if (Tcl_SetVar(interp, argv[1], listArgv[i], 0) == 0) {
	    Tcl_SetResult(interp, (unsigned char*) "couldn't set loop variable", TCL_STATIC);
	    result = TCL_ERROR;
	    break;
	}

	result = Tcl_Eval(interp, argv[3], 0, 0);
	if (result != TCL_OK) {
	    if (result == TCL_CONTINUE) {
		result = TCL_OK;
	    } else if (result == TCL_BREAK) {
		result = TCL_OK;
		break;
	    } else if (result == TCL_ERROR) {
		unsigned char msg[100];
		snprintf(msg, sizeof (msg), "\n    (\"foreach\" body line %d)",
			interp->errorLine);
		Tcl_AddErrorInfo(interp, msg);
		break;
	    } else {
		break;
	    }
	}
    }
    mem_free (listArgv);
    if (result == TCL_OK) {
	Tcl_ResetResult(interp);
    }
    return result;
}
Ejemplo n.º 9
0
static void
Prompt(
    Tcl_Interp *interp,		/* Interpreter to use for prompting. */
    int partial)		/* Non-zero means there already exists a
				 * partial command, so use the secondary
				 * prompt. */
{
    Tcl_Obj *promptCmd;
    int code;
    Tcl_Channel outChannel, errChannel;

    promptCmd = Tcl_GetVar2Ex(interp,
	partial ? "tcl_prompt2" : "tcl_prompt1", NULL, TCL_GLOBAL_ONLY);
    if (promptCmd == NULL) {
    defaultPrompt:
	if (!partial) {
	    /*
	     * We must check that outChannel is a real channel - it is
	     * possible that someone has transferred stdout out of this
	     * interpreter with "interp transfer".
	     */

	    outChannel = Tcl_GetChannel(interp, "stdout", NULL);
	    if (outChannel != (Tcl_Channel) NULL) {
		Tcl_WriteChars(outChannel, "% ", 2);
	    }
	}
    } else {
	code = Tcl_EvalObjEx(interp, promptCmd, TCL_EVAL_GLOBAL);
	if (code != TCL_OK) {
	    Tcl_AddErrorInfo(interp,
		    "\n    (script that generates prompt)");

	    /*
	     * We must check that errChannel is a real channel - it is
	     * possible that someone has transferred stderr out of this
	     * interpreter with "interp transfer".
	     */

	    errChannel = Tcl_GetChannel(interp, "stderr", NULL);
	    if (errChannel != (Tcl_Channel) NULL) {
		Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
		Tcl_WriteChars(errChannel, "\n", 1);
	    }
	    goto defaultPrompt;
	}
    }
    outChannel = Tcl_GetChannel(interp, "stdout", NULL);
    if (outChannel != (Tcl_Channel) NULL) {
	Tcl_Flush(outChannel);
    }
}
Ejemplo n.º 10
0
/* UpdateScrollbar --
 *	Call the -scrollcommand callback to sync the scrollbar.
 * 	Returns: Whatever the -scrollcommand does.
 */
static int UpdateScrollbar(Tcl_Interp *interp, ScrollHandle h)
{
    Scrollable *s = h->scrollPtr;
    WidgetCore *corePtr = h->corePtr;
    char arg1[TCL_DOUBLE_SPACE + 2];
    char arg2[TCL_DOUBLE_SPACE + 2];
    int code;

    h->flags &= ~SCROLL_UPDATE_REQUIRED;

    if (s->scrollCmd == NULL) {
        return TCL_OK;
    }

    arg1[0] = arg2[0] = ' ';
    Tcl_PrintDouble(interp, (double)s->first / s->total, arg1+1);
    Tcl_PrintDouble(interp, (double)s->last / s->total, arg2+1);

    Tcl_Preserve(corePtr);
    code = Tcl_VarEval(interp, s->scrollCmd, arg1, arg2, NULL);
    if (WidgetDestroyed(corePtr)) {
        Tcl_Release(corePtr);
        return TCL_ERROR;
    }
    Tcl_Release(corePtr);

    if (code != TCL_OK && !Tcl_InterpDeleted(interp)) {
        /* Disable the -scrollcommand, add to stack trace:
         */
        ckfree(s->scrollCmd);
        s->scrollCmd = 0;

        Tcl_AddErrorInfo(interp, /* @@@ "horizontal" / "vertical" */
                         "\n    (scrolling command executed by ");
        Tcl_AddErrorInfo(interp, Tk_PathName(h->corePtr->tkwin));
        Tcl_AddErrorInfo(interp, ")");
    }
    return code;
}
Ejemplo n.º 11
0
static void
Prompt(
    Tcl_Interp *interp,		/* Interpreter to use for prompting. */
    InteractiveState *isPtr)	/* InteractiveState. Filled with PROMPT_NONE
				 * after a prompt is printed. */
{
    Tcl_Obj *promptCmdPtr;
    int code;
    Tcl_Channel chan;

    if (isPtr->prompt == PROMPT_NONE) {
	return;
    }

    promptCmdPtr = Tcl_GetVar2Ex(interp,
	    (isPtr->prompt==PROMPT_CONTINUE ? "tcl_prompt2" : "tcl_prompt1"),
	    NULL, TCL_GLOBAL_ONLY);

    if (Tcl_InterpDeleted(interp)) {
	return;
    }
    if (promptCmdPtr == NULL) {
    defaultPrompt:
	if (isPtr->prompt == PROMPT_START) {
	    chan = Tcl_GetStdChannel(TCL_STDOUT);
	    if (chan != NULL) {
		Tcl_WriteChars(chan, DEFAULT_PRIMARY_PROMPT,
			strlen(DEFAULT_PRIMARY_PROMPT));
	    }
	}
    } else {
	code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL);
	if (code != TCL_OK) {
	    Tcl_AddErrorInfo(interp,
		    "\n    (script that generates prompt)");
	    chan = Tcl_GetStdChannel(TCL_STDERR);
	    if (chan != NULL) {
		Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
		Tcl_WriteChars(chan, "\n", 1);
	    }
	    goto defaultPrompt;
	}
    }

    chan = Tcl_GetStdChannel(TCL_STDOUT);
    if (chan != NULL) {
	Tcl_Flush(chan);
    }
    isPtr->prompt = PROMPT_NONE;
}
Ejemplo n.º 12
0
static PyObject *
Tkapp_AddErrorInfo(PyObject *self, PyObject *args)
{
	char *msg;

	if (!PyArg_ParseTuple(args, "s:adderrorinfo", &msg))
		return NULL;
	ENTER_TCL
	Tcl_AddErrorInfo(Tkapp_Interp(self), msg);
	LEAVE_TCL

	Py_INCREF(Py_None);
	return Py_None;
}
Ejemplo n.º 13
0
static void
Prompt(
    Tcl_Interp *interp,		/* Interpreter to use for prompting. */
    PromptType *promptPtr)	/* Points to type of prompt to print. Filled
				 * with PROMPT_NONE after a prompt is
				 * printed. */
{
    Tcl_Obj *promptCmdPtr;
    int code;
    Tcl_Channel outChannel, errChannel;

    if (*promptPtr == PROMPT_NONE) {
	return;
    }

    promptCmdPtr = Tcl_GetVar2Ex(interp,
	    ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"),
	    NULL, TCL_GLOBAL_ONLY);

    if (Tcl_InterpDeleted(interp)) {
	return;
    }
    if (promptCmdPtr == NULL) {
    defaultPrompt:
	outChannel = Tcl_GetStdChannel(TCL_STDOUT);
	if ((*promptPtr == PROMPT_START)
		&& (outChannel != (Tcl_Channel) NULL)) {
	    Tcl_WriteChars(outChannel, DEFAULT_PRIMARY_PROMPT,
		    strlen(DEFAULT_PRIMARY_PROMPT));
	}
    } else {
	code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL);
	if (code != TCL_OK) {
	    Tcl_AddErrorInfo(interp,
		    "\n    (script that generates prompt)");
	    errChannel = Tcl_GetStdChannel(TCL_STDERR);
	    if (errChannel != (Tcl_Channel) NULL) {
		Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
		Tcl_WriteChars(errChannel, "\n", 1);
	    }
	    goto defaultPrompt;
	}
    }

    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
    if (outChannel != (Tcl_Channel) NULL) {
	Tcl_Flush(outChannel);
    }
    *promptPtr = PROMPT_NONE;
}
Ejemplo n.º 14
0
static int stateHandlerInvoke(Tcl_Event* p, int flags) {
	/* called from Tcl event loop, when the connection status changes */
	connectionEvent *cev =(connectionEvent *) p;
	pvInfo *info = cev->info;
	Tcl_Obj *script = Tcl_DuplicateObj(info->connectprefix);
	Tcl_IncrRefCount(script);

	/* append cmd of PV and up/down */
	Tcl_Obj *cmdname = Tcl_NewObj();
    Tcl_GetCommandFullName(info->interp, info->cmd, cmdname);
	
	int code = Tcl_ListObjAppendElement(info->interp, script, cmdname);
	if (code != TCL_OK) {
		goto bgerr;
	}
	
	if (cev->op == CA_OP_CONN_UP) {
		info->connected = 1;
		/* Retrieve information about type and number of elements */
		info->nElem = ca_element_count(info->id);
		info->type  = ca_field_type(info->id);
	} else {
		info->connected = 0;
	}
	
	code = Tcl_ListObjAppendElement(info->interp, script, Tcl_NewBooleanObj(info->connected));
	if (code != TCL_OK) {
		goto bgerr;
	}


	Tcl_Preserve(info->interp);
	code = Tcl_EvalObjEx(info->interp, script, TCL_EVAL_GLOBAL);

	if (code != TCL_OK) { goto bgerr; }

	Tcl_Release(info->interp);
	Tcl_DecrRefCount(script);
	/* this event was successfully handled */
	return 1; 
bgerr:
	/* put error in background */
	Tcl_AddErrorInfo(info->interp, "\n    (epics connection callback script)");
	Tcl_BackgroundException(info->interp, code);
	
	/* this event was successfully handled */
	return 1;
}
Ejemplo n.º 15
0
/**
   @see TURBINE_CHECK
*/
static void
turbine_check_failed(Tcl_Interp* interp, turbine_code code,
                     char* format, ...)
{
  char buffer[1024];
  char* p = &buffer[0];
  va_list ap;
  va_start(ap, format);
  append(p, "\n");
  p += vsprintf(p, format, ap);
  va_end(ap);
  append(p, "\n%s", "turbine error: ");
  turbine_code_tostring(p, code);
  printf("turbine_check_failed: %s\n", buffer);
  Tcl_AddErrorInfo(interp, buffer);
}
Ejemplo n.º 16
0
static void
AfterProc(
    ClientData clientData)	/* Describes command to execute. */
{
    AfterInfo *afterPtr = clientData;
    AfterAssocData *assocPtr = afterPtr->assocPtr;
    AfterInfo *prevPtr;
    int result;
    Tcl_Interp *interp;

    /*
     * First remove the callback from our list of callbacks; otherwise someone
     * could delete the callback while it's being executed, which could cause
     * a core dump.
     */

    if (assocPtr->firstAfterPtr == afterPtr) {
	assocPtr->firstAfterPtr = afterPtr->nextPtr;
    } else {
	for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
		prevPtr = prevPtr->nextPtr) {
	    /* Empty loop body. */
	}
	prevPtr->nextPtr = afterPtr->nextPtr;
    }

    /*
     * Execute the callback.
     */

    interp = assocPtr->interp;
    Tcl_Preserve(interp);
    result = Tcl_EvalObjEx(interp, afterPtr->commandPtr, TCL_EVAL_GLOBAL);
    if (result != TCL_OK) {
	Tcl_AddErrorInfo(interp, "\n    (\"after\" script)");
	Tcl_BackgroundException(interp, result);
    }
    Tcl_Release(interp);

    /*
     * Free the memory for the callback.
     */

    Tcl_DecrRefCount(afterPtr->commandPtr);
    ckfree(afterPtr);
}
Ejemplo n.º 17
0
/*
** For the markup <a href=XXX>, find out if the URL has been visited
** before or not.  Return COLOR_Visited or COLOR_Unvisited, as
** appropriate.
**
** This routine may invoke a callback procedure which could delete
** the HTML widget.  The calling function should call HtmlLock()
** if it needs the widget structure to be preserved.
*/
static int GetLinkColor(HtmlWidget *htmlPtr, char *zURL){
  char *zCmd;
  int result;
  int isVisited;

  if( htmlPtr->tkwin==0 ){
    TestPoint(0);
    return COLOR_Normal;
  }
  if( htmlPtr->zIsVisited==0 || htmlPtr->zIsVisited[0]==0 ){
    TestPoint(0);
    return COLOR_Unvisited;
  }
  zCmd = HtmlAlloc( strlen(htmlPtr->zIsVisited) + strlen(zURL) + 10 );
  if( zCmd==0 ){
    TestPoint(0);
    return COLOR_Unvisited;
  }
  sprintf(zCmd,"%s {%s}",htmlPtr->zIsVisited, zURL);
  HtmlLock(htmlPtr);
  result = Tcl_GlobalEval(htmlPtr->interp,zCmd);
  HtmlFree(zCmd);
  if( HtmlUnlock(htmlPtr) ){
    return COLOR_Unvisited;
  }
  if( result!=TCL_OK ){
    TestPoint(0);
    goto errorOut;
  }
  result = Tcl_GetBoolean(htmlPtr->interp,
                          Tcl_GetStringResult(htmlPtr->interp), &isVisited);
  if( result!=TCL_OK ){
    TestPoint(0);
    goto errorOut;
  }
  TestPoint(0);
  return isVisited ? COLOR_Visited : COLOR_Unvisited;

  errorOut:
  Tcl_AddErrorInfo(htmlPtr->interp,
    "\n    (\"-isvisitedcommand\" command executed by html widget)");
  Tcl_BackgroundError(htmlPtr->interp);
  TestPoint(0);
  return COLOR_Unvisited;
}
Ejemplo n.º 18
0
/*
 *----------------------------------------------------------------------
 *
 * mongotcl_tcllist_to_cursor_fields --
 *
 *      Takes a Tcl list that should contain pairs of field names and
 *      0/1 values and a mongotcl cursor clientdata structure.
 *
 *      If successful, sets a bson object in the cursor client data to
 *      contain the equivalent, appropriate bson for passing to 
 *      mongo_cursor_set_fields
 *
 *      If unsuccessful, returns TCL_ERROR and sets the bson pointer
 *      to NULL.
 *
 * Results:
 *      A standard Tcl result.
 *
 *
 *----------------------------------------------------------------------
 */
int
mongotcl_tcllist_to_cursor_fields (Tcl_Interp *interp, Tcl_Obj *fieldList, mongotcl_cursorClientData *mc) {
	Tcl_Obj **listObjv;
	int listObjc;
	int i;

	if (Tcl_ListObjGetElements (interp, fieldList, &listObjc, &listObjv) == TCL_ERROR) {
		Tcl_AddErrorInfo (interp, "while reading field list");
		return TCL_ERROR;
	}

	if (listObjc & 1) {
		Tcl_SetObjResult (interp, Tcl_NewStringObj ("field list must have even number of elements", -1));
		return TCL_ERROR;
	}

	if (mc->fieldsBson == NULL) {
		mc->fieldsBson = (bson *)ckalloc(sizeof(bson));
	}
	bson_init(mc->fieldsBson);

	for (i = 0; i < listObjc; i += 2) {
		int want;
		char *key = Tcl_GetString (listObjv[i]);

		if (Tcl_GetIntFromObj (interp, listObjv[i+1], &want) == TCL_ERROR) {
		  bson_error:
			return mongotcl_setBsonError (interp, mc->fieldsBson);
		}

		if (bson_append_int (mc->fieldsBson, key, want) != BSON_OK) {
			goto bson_error;
		}
	}

	if (bson_finish (mc->fieldsBson) != BSON_OK) {
		goto bson_error;
	}

	mongo_cursor_set_fields (mc->cursor, mc->fieldsBson);

	return TCL_OK;
}
Ejemplo n.º 19
0
/*
** Delete all input controls.  This happens when the HTML widget
** is cleared.
**
** When the TCL "exit" command is invoked, the order of operations
** here is very touchy.  
*/
void HtmlDeleteControls(HtmlWidget *htmlPtr){
  HtmlElement *p;        /* For looping over all controls */
  Tcl_Interp *interp;    /* The interpreter */
  
  interp = htmlPtr->interp;
  p = htmlPtr->firstInput;
  htmlPtr->firstInput = 0;
  htmlPtr->lastInput = 0;
  htmlPtr->nInput = 0;
  if( p==0 || htmlPtr->tkwin==0 ) return;
  HtmlLock(htmlPtr);
  for(; p; p=p->input.pNext){
    if( p->input.pForm && p->input.pForm->form.id>0 
         && htmlPtr->zFormCommand && htmlPtr->zFormCommand[0]
         && !Tcl_InterpDeleted(interp) && htmlPtr->clipwin ){
      Tcl_DString cmd;
      int result;
      char zBuf[60];
      Tcl_DStringInit(&cmd);
      Tcl_DStringAppend(&cmd, htmlPtr->zFormCommand, -1);
      sprintf(zBuf," %d flush", p->input.pForm->form.id);
      Tcl_DStringAppend(&cmd, zBuf, -1);
      result = Tcl_GlobalEval(htmlPtr->interp, Tcl_DStringValue(&cmd));
      Tcl_DStringFree(&cmd);
      if( !Tcl_InterpDeleted(interp) ){
        if( result != TCL_OK ){
          Tcl_AddErrorInfo(htmlPtr->interp,
             "\n    (-formcommand flush callback executed by html widget)");
          Tcl_BackgroundError(htmlPtr->interp);
          TestPoint(0);
        }
        Tcl_ResetResult(htmlPtr->interp);
      }
      p->input.pForm->form.id = 0;
    }
    if( p->input.tkwin ){
      if( htmlPtr->clipwin!=0 ) Tk_DestroyWindow(p->input.tkwin);
      p->input.tkwin = 0;
    }
    p->input.sized = 0;
  }
  HtmlUnlock(htmlPtr);
}
Ejemplo n.º 20
0
/********************************************************************************************
 * test_Source
 * purpose : This function replaces the "source" command of the TCL
 * input   : clientData - used for creating new command in tcl
 *           interp - interpreter for tcl commands
 *           argc - number of parameters entered to the new command
 *           argv - the parameters entered to the tcl command
 * output  : none
 * return  : TCL_OK
 ********************************************************************************************/
int test_Source(ClientData clientData, Tcl_Interp *interp,int argc, char *argv[])
{
    FILE* exists;
    char* fileBuf;

    if (argc != 2)
    {
        Tcl_SetResult(interp, (char *)"wrong # args: should be \"source <filename>\"", TCL_STATIC);
        return TCL_ERROR;
    }

    /* First see if we've got such a file on the disk */
    exists = fopen(argv[1], "r");
    if (exists == NULL)
    {
        /* File doesn't exist - get from compiled array */
        fileBuf = tclGetFile(argv[1]);
        if (fileBuf == NULL)
        {
            /* No such luck - we don't have a file to show */
            char error[300];
            sprintf(error, "file %s not found", argv[1]);
            Tcl_SetResult(interp, error, TCL_VOLATILE);
            return TCL_ERROR;
        }
        else
        {
            /* Found! */
            int retCode;
            retCode = Tcl_Eval(interp, fileBuf);
            if (retCode == TCL_ERROR)
            {
                char error[300];
                sprintf(error, "\n    (file \"%s\" line %d)", argv[1], interp->errorLine);
                Tcl_AddErrorInfo(interp, error);
            }
            return retCode;
        }
    }

    /* File exists - evaluate from the file itself */
    return Tcl_EvalFile(interp, argv[1]);
}
Ejemplo n.º 21
0
int
TkBackgroundEvalObjv(
    Tcl_Interp *interp,
    int objc,
    Tcl_Obj *const *objv,
    int flags)
{
    Tcl_InterpState state;
    int n, r = TCL_OK;

    /*
     * Record the state of the interpreter.
     */

    Tcl_Preserve(interp);
    state = Tcl_SaveInterpState(interp, TCL_OK);

    /*
     * Evaluate the command and handle any error.
     */

    for (n = 0; n < objc; ++n) {
	Tcl_IncrRefCount(objv[n]);
    }
    r = Tcl_EvalObjv(interp, objc, objv, flags);
    for (n = 0; n < objc; ++n) {
	Tcl_DecrRefCount(objv[n]);
    }
    if (r == TCL_ERROR) {
	Tcl_AddErrorInfo(interp, "\n    (background event handler)");
	Tcl_BackgroundException(interp, r);
    }

    /*
     * Restore the state of the interpreter.
     */

    (void) Tcl_RestoreInterpState(interp, state);
    Tcl_Release(interp);

    return r;
}
Ejemplo n.º 22
0
static void
Prompt(
    Tcl_Interp *interp,		/* Interpreter to use for prompting. */
    InteractiveState *isPtr) /* InteractiveState. */
{
    Tcl_Obj *promptCmdPtr;
    int code;
    Tcl_Channel chan;

    promptCmdPtr = Tcl_GetVar2Ex(interp,
	isPtr->gotPartial ? "tcl_prompt2" : "tcl_prompt1", NULL, TCL_GLOBAL_ONLY);
    if (promptCmdPtr == NULL) {
    defaultPrompt:
	if (!isPtr->gotPartial) {
	    chan = Tcl_GetStdChannel(TCL_STDOUT);
	    if (chan != NULL) {
		Tcl_WriteChars(chan, DEFAULT_PRIMARY_PROMPT,
			strlen(DEFAULT_PRIMARY_PROMPT));
	    }
	}
    } else {
	code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL);
	if (code != TCL_OK) {
	    Tcl_AddErrorInfo(interp,
		    "\n    (script that generates prompt)");
	    if (Tcl_GetStringResult(interp)[0] != '\0') {
		chan = Tcl_GetStdChannel(TCL_STDERR);
		if (chan != NULL) {
		    Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
		    Tcl_WriteChars(chan, "\n", 1);
		}
	    }
	    goto defaultPrompt;
	}
    }

    chan = Tcl_GetStdChannel(TCL_STDOUT);
    if (chan != NULL) {
	Tcl_Flush(chan);
    }
}
Ejemplo n.º 23
0
/*
 * ------------------------------------------------------------------------
 *  Itk_ArchOptConfigError()
 *
 *  Simply utility which adds error information after a option
 *  configuration fails.  Adds traceback information to the given
 *  interpreter.
 * ------------------------------------------------------------------------
 */
void
Itk_ArchOptConfigError(
    Tcl_Interp *interp,            /* interpreter handling this object */
    ArchInfo *info,                /* info associated with mega-widget */
    ArchOption *archOpt)           /* configuration option that failed */
{
    Tcl_Obj *objPtr;

    objPtr = Tcl_NewStringObj((char*)NULL, 0);
    Tcl_IncrRefCount(objPtr);

    Tcl_AppendToObj(objPtr, "\n    (while configuring option \"", -1);
    Tcl_AppendToObj(objPtr, archOpt->switchName, -1);
    Tcl_AppendToObj(objPtr, "\"", -1);

    if (info->itclObj && info->itclObj->accessCmd) {
        Tcl_AppendToObj(objPtr, " for widget \"", -1);
        Tcl_GetCommandFullName(interp, info->itclObj->accessCmd, objPtr);
        Tcl_AppendToObj(objPtr, "\")", -1);
    }
    Tcl_AddErrorInfo(interp, Tcl_GetStringFromObj(objPtr, (int*)NULL));
    Tcl_DecrRefCount(objPtr);
}
Ejemplo n.º 24
0
/*-----------------------------------------------------------------------------
 * EvalTrapCode --
 *     Run code as the result of a signal.  The symbolic signal name is
 * formatted into the command replacing %S with the symbolic signal name.
 *
 * Parameters:
 *   o interp - The interpreter to run the signal in. If an error
 *     occures, then the result will be left in the interp.
 *   o signalNum - The signal number of the signal that occured.
 * Return:
 *   TCL_OK or TCL_ERROR.
 *-----------------------------------------------------------------------------
 */
static int
EvalTrapCode (Tcl_Interp *interp, int signalNum)
{
    int          result;
    Tcl_DString  command;
    Tcl_Obj     *saveObjPtr;

    saveObjPtr = TclX_SaveResultErrorInfo (interp);
    Tcl_ResetResult (interp);

    /*
     * Format the signal name into the command.  This also allows the signal
     * to be reset in the command.
     */

    result = FormatTrapCode (interp,
                             signalNum,
                             &command);
    if (result == TCL_OK)
        result = Tcl_GlobalEval (interp, 
                                 command.string);

    Tcl_DStringFree (&command);

    if (result == TCL_ERROR) {
        char errorInfo [128];

        sprintf (errorInfo, "\n    while executing signal trap code for %s%s",
                 Tcl_SignalId (signalNum), " signal");
        Tcl_AddErrorInfo (interp, errorInfo);

        return TCL_ERROR;
    }
    
    TclX_RestoreResultErrorInfo (interp, saveObjPtr);
    return TCL_OK;
}
Ejemplo n.º 25
0
	/* ARGSUSED */
int
Tcl_EvalCmd(
    void *dummy			/* Not used. */
    , Tcl_Interp *interp			/* Current interpreter. */
    , int argc				/* Number of arguments. */
    , unsigned char **argv		/* Argument strings. */
    )
{
    int result;
    unsigned char *cmd;

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" arg ?arg ...?\"", 0);
	return TCL_ERROR;
    }
    if (argc == 2) {
	result = Tcl_Eval(interp, argv[1], 0, 0);
    } else {

	/*
	 * More than one argument:  concatenate them together with spaces
	 * between, then evaluate the result.
	 */

	cmd = Tcl_Concat (interp->pool, argc-1, argv+1);
	result = Tcl_Eval(interp, cmd, 0, 0);
	mem_free(cmd);
    }
    if (result == TCL_ERROR) {
	unsigned char msg[60];
	snprintf(msg, sizeof (msg), "\n    (\"eval\" body line %d)", interp->errorLine);
	Tcl_AddErrorInfo(interp, msg);
    }
    return result;
}
Ejemplo n.º 26
0
int
Tk_CreateConsoleWindow(
    Tcl_Interp *interp)		/* Interpreter to use for prompting. */
{
    Tcl_Channel chan;
    ConsoleInfo *info;
    Tk_Window mainWindow;
    Tcl_Command token;
    int result = TCL_OK;
    int haveConsoleChannel = 1;

    /* Init an interp with Tcl and Tk */
    Tcl_Interp *consoleInterp = Tcl_CreateInterp();
    if (Tcl_Init(consoleInterp) != TCL_OK) {
	goto error;
    }
    if (Tk_Init(consoleInterp) != TCL_OK) {
	goto error;
    }

    /*
     * Fetch the instance data from whatever std channel is a
     * console channel.  If none, create fresh instance data.
     */

    if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDIN))
	    == &consoleChannelType) {
    } else if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDOUT))
	    == &consoleChannelType) {
    } else if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDERR))
	    == &consoleChannelType) {
    } else {
	haveConsoleChannel = 0;
    }

    if (haveConsoleChannel) {
	ChannelData *data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
	info = data->info;
	if (info->consoleInterp) {
	    /* New ConsoleInfo for a new console window */
	    info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
	    info->refCount = 0;

	    /* Update any console channels to make use of the new console */
	    if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDIN))
		    == &consoleChannelType) {
		data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
		data->info->refCount--;
		data->info = info;
		data->info->refCount++;
	    }
	    if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDOUT))
		    == &consoleChannelType) {
		data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
		data->info->refCount--;
		data->info = info;
		data->info->refCount++;
	    }
	    if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDERR))
		    == &consoleChannelType) {
		data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
		data->info->refCount--;
		data->info = info;
		data->info->refCount++;
	    }
	}
    } else {
	info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
	info->refCount = 0;
    }

    info->consoleInterp = consoleInterp;
    info->interp = interp;

    Tcl_CallWhenDeleted(consoleInterp, InterpDeleteProc, info);
    info->refCount++;
    Tcl_CreateThreadExitHandler(DeleteConsoleInterp, consoleInterp);

    /*
     * Add console commands to the interp
     */

    token = Tcl_CreateObjCommand(interp, "console", ConsoleObjCmd, info,
	    ConsoleDeleteProc);
    info->refCount++;

    /*
     * We don't have to count the ref held by the [consoleinterp] command
     * in the consoleInterp.  The ref held by the consoleInterp delete
     * handler takes care of us.
     */
    Tcl_CreateObjCommand(consoleInterp, "consoleinterp", InterpreterObjCmd,
	    info, NULL);

    mainWindow = Tk_MainWindow(interp);
    if (mainWindow) {
	Tk_CreateEventHandler(mainWindow, StructureNotifyMask,
		ConsoleEventProc, info);
	info->refCount++;
    }

    Tcl_Preserve(consoleInterp);
    result = Tcl_GlobalEval(consoleInterp, "source $tk_library/console.tcl");
    if (result == TCL_ERROR) {
	Tcl_SetReturnOptions(interp,
		Tcl_GetReturnOptions(consoleInterp, result));
	Tcl_SetObjResult(interp, Tcl_GetObjResult(consoleInterp));
    }
    Tcl_Release(consoleInterp);
    if (result == TCL_ERROR) {
	Tcl_DeleteCommandFromToken(interp, token);
	mainWindow = Tk_MainWindow(interp);
	if (mainWindow) {
	    Tk_DeleteEventHandler(mainWindow, StructureNotifyMask,
		    ConsoleEventProc, info);
	    if (--info->refCount <= 0) {
		ckfree((char *) info);
	    }
	}
	goto error;
    }
    return TCL_OK;

  error:
    Tcl_AddErrorInfo(interp, "\n    (creating console window)");
    if (!Tcl_InterpDeleted(consoleInterp)) {
	Tcl_DeleteInterp(consoleInterp);
    }
    return TCL_ERROR;
}
Ejemplo n.º 27
0
void
TkpDisplayScale(
    ClientData clientData)	/* Widget record for scale. */
{
    TkScale *scalePtr = (TkScale *) clientData;
    Tk_Window tkwin = scalePtr->tkwin;
    Tcl_Interp *interp = scalePtr->interp;
    Pixmap pixmap;
    int result;
    char string[PRINT_CHARS];
    XRectangle drawnArea;
    Tcl_DString buf;

    scalePtr->flags &= ~REDRAW_PENDING;
    if ((scalePtr->tkwin == NULL) || !Tk_IsMapped(scalePtr->tkwin)) {
	goto done;
    }

    /*
     * Invoke the scale's command if needed.
     */

    Tcl_Preserve(scalePtr);
    if ((scalePtr->flags & INVOKE_COMMAND) && (scalePtr->command != NULL)) {
	Tcl_Preserve(interp);
	sprintf(string, scalePtr->format, scalePtr->value);
	Tcl_DStringInit(&buf);
	Tcl_DStringAppend(&buf, scalePtr->command, -1);
	Tcl_DStringAppend(&buf, " ", -1);
	Tcl_DStringAppend(&buf, string, -1);
	result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0);
	Tcl_DStringFree(&buf);
	if (result != TCL_OK) {
	    Tcl_AddErrorInfo(interp, "\n    (command executed by scale)");
	    Tcl_BackgroundException(interp, result);
	}
	Tcl_Release(interp);
    }
    scalePtr->flags &= ~INVOKE_COMMAND;
    if (scalePtr->flags & SCALE_DELETED) {
	Tcl_Release(scalePtr);
	return;
    }
    Tcl_Release(scalePtr);

#ifndef TK_NO_DOUBLE_BUFFERING
    /*
     * In order to avoid screen flashes, this function redraws the scale in a
     * pixmap, then copies the pixmap to the screen in a single operation.
     * This means that there's no point in time where the on-sreen image has
     * been cleared.
     */

    pixmap = Tk_GetPixmap(scalePtr->display, Tk_WindowId(tkwin),
	    Tk_Width(tkwin), Tk_Height(tkwin), Tk_Depth(tkwin));
#else
    pixmap = Tk_WindowId(tkwin);
#endif /* TK_NO_DOUBLE_BUFFERING */
    drawnArea.x = 0;
    drawnArea.y = 0;
    drawnArea.width = Tk_Width(tkwin);
    drawnArea.height = Tk_Height(tkwin);

    /*
     * Much of the redisplay is done totally differently for horizontal and
     * vertical scales. Handle the part that's different.
     */

    if (scalePtr->orient == ORIENT_VERTICAL) {
	DisplayVerticalScale(scalePtr, pixmap, &drawnArea);
    } else {
	DisplayHorizontalScale(scalePtr, pixmap, &drawnArea);
    }

    /*
     * Now handle the part of redisplay that is the same for horizontal and
     * vertical scales: border and traversal highlight.
     */

    if (scalePtr->flags & REDRAW_OTHER) {
	if (scalePtr->relief != TK_RELIEF_FLAT) {
	    Tk_Draw3DRectangle(tkwin, pixmap, scalePtr->bgBorder,
		    scalePtr->highlightWidth, scalePtr->highlightWidth,
		    Tk_Width(tkwin) - 2*scalePtr->highlightWidth,
		    Tk_Height(tkwin) - 2*scalePtr->highlightWidth,
		    scalePtr->borderWidth, scalePtr->relief);
	}
	if (scalePtr->highlightWidth != 0) {
	    GC gc;

	    if (scalePtr->flags & GOT_FOCUS) {
		gc = Tk_GCForColor(scalePtr->highlightColorPtr, pixmap);
	    } else {
		gc = Tk_GCForColor(
                        Tk_3DBorderColor(scalePtr->highlightBorder), pixmap);
	    }
	    Tk_DrawFocusHighlight(tkwin, gc, scalePtr->highlightWidth, pixmap);
	}
    }

#ifndef TK_NO_DOUBLE_BUFFERING
    /*
     * Copy the information from the off-screen pixmap onto the screen, then
     * delete the pixmap.
     */

    XCopyArea(scalePtr->display, pixmap, Tk_WindowId(tkwin),
	    scalePtr->copyGC, drawnArea.x, drawnArea.y, drawnArea.width,
	    drawnArea.height, drawnArea.x, drawnArea.y);
    Tk_FreePixmap(scalePtr->display, pixmap);
#endif /* TK_NO_DOUBLE_BUFFERING */

  done:
    scalePtr->flags &= ~REDRAW_ALL;
}
Ejemplo n.º 28
0
/*
 * ------------------------------------------------------------------------
 *  Itk_ArchetypeInit()
 *
 *  Invoked by Itk_Init() whenever a new interpreter is created to
 *  declare the procedures used in the itk::Archetype base class.
 * ------------------------------------------------------------------------
 */
int
Itk_ArchetypeInit(
    Tcl_Interp *interp)  /* interpreter to be updated */
{
    ArchMergeInfo *mergeInfo;
    Tcl_Namespace *parserNs;
    Tcl_Namespace *nsPtr;
    Tcl_Command cmd;
    int i;

    /*
     *  Declare all of the C routines that are integrated into
     *  the Archetype base class.
     */
    if (Itcl_RegisterObjC(interp,
            "Archetype-init", Itk_ArchInitOptsCmd,
            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ||

        Itcl_RegisterObjC(interp,
            "Archetype-delete", Itk_ArchDeleteOptsCmd,
            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ||

        Itcl_RegisterObjC(interp,
            "Archetype-itk_component", Itk_ArchComponentCmd,
            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ||

        Itcl_RegisterObjC(interp,
            "Archetype-itk_option", Itk_ArchOptionCmd,
            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ||

        Itcl_RegisterObjC(interp,
            "Archetype-itk_initialize", Itk_ArchInitCmd,
            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ||

        Itcl_RegisterObjC(interp,
            "Archetype-component", Itk_ArchCompAccessCmd,
            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ||

        Itcl_RegisterObjC(interp,
            "Archetype-configure",Itk_ArchConfigureCmd,
            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK ||

        Itcl_RegisterObjC(interp,
            "Archetype-cget",Itk_ArchCgetCmd,
            (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL) != TCL_OK) {

        return TCL_ERROR;
    }

    /*
     * Build the ensemble used to implement [_archetype].
     */

    nsPtr = Tcl_CreateNamespace(interp, "::itcl::builtin::Archetype",
        NULL, NULL);
    if (nsPtr == NULL) {
        nsPtr = Tcl_FindNamespace(interp, "::itcl::builtin::Archetype", NULL, 0);
    }
if (nsPtr == NULL) {
fprintf(stderr, "error in creating namespace: ::itcl::builtin::Archetype \n");
}
    cmd = Tcl_CreateEnsemble(interp, nsPtr->fullName, nsPtr,
       TCL_ENSEMBLE_PREFIX);
    Tcl_Export(interp, nsPtr, "[a-z]*", 1);
    for (i=0 ; archetypeCmds[i].name!=NULL ; i++) {
        Tcl_CreateObjCommand(interp, archetypeCmds[i].name,
                archetypeCmds[i].proc, NULL, NULL);
    }

    /*
     *  Create the namespace containing the option parser commands.
     */
    mergeInfo = (ArchMergeInfo*)ckalloc(sizeof(ArchMergeInfo));
    Tcl_InitHashTable(&mergeInfo->usualCode, TCL_STRING_KEYS);
    mergeInfo->archInfo    = NULL;
    mergeInfo->archComp    = NULL;
    mergeInfo->optionTable = NULL;

    parserNs = Tcl_CreateNamespace(interp, "::itk::option-parser",
        (ClientData)mergeInfo, Itcl_ReleaseData);

    if (!parserNs) {
        Itk_DelMergeInfo((char*)mergeInfo);
        Tcl_AddErrorInfo(interp, "\n    (while initializing itk)");
        return TCL_ERROR;
    }
    Itcl_PreserveData((ClientData)mergeInfo);
    Itcl_EventuallyFree((ClientData)mergeInfo, Itk_DelMergeInfo);

    Tcl_CreateObjCommand(interp, "::itk::option-parser::keep",
        Itk_ArchOptKeepCmd,
        (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL);

    Tcl_CreateObjCommand(interp, "::itk::option-parser::ignore",
        Itk_ArchOptIgnoreCmd,
        (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL);

    Tcl_CreateObjCommand(interp, "::itk::option-parser::rename",
        Itk_ArchOptRenameCmd,
        (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL);

    Tcl_CreateObjCommand(interp, "::itk::option-parser::usual",
        Itk_ArchOptUsualCmd,
        (ClientData)mergeInfo, (Tcl_CmdDeleteProc*)NULL);

    /*
     *  Add the "itk::usual" command to register option handling code.
     */
    Tcl_CreateObjCommand(interp, "::itk::usual", Itk_UsualCmd,
        (ClientData)mergeInfo, Itcl_ReleaseData);
    Itcl_PreserveData((ClientData)mergeInfo);

    return TCL_OK;
}
Ejemplo n.º 29
0
static int
HandleTclCommand(
    ClientData clientData,	/* Information about command to execute. */
    int offset,			/* Return selection bytes starting at this
				 * offset. */
    char *buffer,		/* Place to store converted selection. */
    int maxBytes)		/* Maximum # of bytes to store at buffer. */
{
    CommandInfo *cmdInfoPtr = clientData;
    int length;
    Tcl_Obj *command;
    const char *string;
    Tcl_Interp *interp = cmdInfoPtr->interp;
    Tcl_InterpState savedState;
    int extraBytes, charOffset, count, numChars, code;
    const char *p;

    /*
     * We must also protect the interpreter and the command from being deleted
     * too soon.
     */

    Tcl_Preserve(clientData);
    Tcl_Preserve(interp);

    /*
     * Compute the proper byte offset in the case where the last chunk split a
     * character.
     */

    if (offset == cmdInfoPtr->byteOffset) {
	charOffset = cmdInfoPtr->charOffset;
	extraBytes = strlen(cmdInfoPtr->buffer);
	if (extraBytes > 0) {
	    strcpy(buffer, cmdInfoPtr->buffer);
	    maxBytes -= extraBytes;
	    buffer += extraBytes;
	}
    } else {
	cmdInfoPtr->byteOffset = 0;
	cmdInfoPtr->charOffset = 0;
	extraBytes = 0;
	charOffset = 0;
    }

    /*
     * First, generate a command by taking the command string and appending
     * the offset and maximum # of bytes.
     */

    command = Tcl_ObjPrintf("%s %d %d",
	    cmdInfoPtr->command, charOffset, maxBytes);
    Tcl_IncrRefCount(command);

    /*
     * Execute the command. Be sure to restore the state of the interpreter
     * after executing the command.
     */

    savedState = Tcl_SaveInterpState(interp, TCL_OK);
    code = Tcl_EvalObjEx(interp, command, TCL_EVAL_GLOBAL);
    Tcl_DecrRefCount(command);
    if (code == TCL_OK) {
	/*
	 * TODO: This assumes that bytes are characters; that's not true!
	 */

	string = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length);
	count = (length > maxBytes) ? maxBytes : length;
	memcpy(buffer, string, (size_t) count);
	buffer[count] = '\0';

	/*
	 * Update the partial character information for the next retrieval if
	 * the command has not been deleted.
	 */

	if (cmdInfoPtr->interp != NULL) {
	    if (length <= maxBytes) {
		cmdInfoPtr->charOffset += Tcl_NumUtfChars(string, -1);
		cmdInfoPtr->buffer[0] = '\0';
	    } else {
		p = string;
		string += count;
		numChars = 0;
		while (p < string) {
		    p = Tcl_UtfNext(p);
		    numChars++;
		}
		cmdInfoPtr->charOffset += numChars;
		length = p - string;
		if (length > 0) {
		    strncpy(cmdInfoPtr->buffer, string, (size_t) length);
		}
		cmdInfoPtr->buffer[length] = '\0';
	    }
	    cmdInfoPtr->byteOffset += count + extraBytes;
	}
	count += extraBytes;
    } else {
	/*
	 * Something went wrong. Log errors as background errors, and silently
	 * drop everything else.
	 */

	if (code == TCL_ERROR) {
	    Tcl_AddErrorInfo(interp, "\n    (command handling selection)");
	    Tcl_BackgroundException(interp, code);
	}
	count = -1;
    }
    (void) Tcl_RestoreInterpState(interp, savedState);

    Tcl_Release(clientData);
    Tcl_Release(interp);
    return count;
}
Ejemplo n.º 30
0
/*
** The input azSeries[] is a sequence of URIs.  This command must
** resolve them all and put the result in the interp->result field
** of the interpreter associated with the HTML widget.  Return 
** TCL_OK on success and TCL_ERROR if there is a failure.
**
** This function can cause the HTML widget to be deleted or changed
** arbitrarily. 
*/
int HtmlCallResolver(
  HtmlWidget *htmlPtr,      /* The widget that is doing the resolving. */
  char **azSeries           /* A list of URIs.  NULL terminated */
){
  int rc = TCL_OK;          /* Return value of this function. */
  char *z;

  HtmlVerifyLock(htmlPtr);
  if( htmlPtr->zResolverCommand && htmlPtr->zResolverCommand[0] ){
    /*
    ** Append the current base URI then the azSeries arguments to the
    ** TCL command specified by the -resolvercommand optoin, then execute
    ** the result.
    **
    ** The -resolvercommand could do nasty things, such as delete
    ** the HTML widget out from under us.  Be prepared for the worst.
    */
    Tcl_DString cmd;
    Tcl_DStringInit(&cmd);
    Tcl_DStringAppend(&cmd, htmlPtr->zResolverCommand, -1);
    if( htmlPtr->zBaseHref && htmlPtr->zBaseHref[0] ){
      z = Trim(htmlPtr->zBaseHref);
    }else if( htmlPtr->zBase && htmlPtr->zBase[0] ){
      z = Trim(htmlPtr->zBase);
    }
    if( z ){
      Tcl_DStringAppendElement(&cmd, z);
      HtmlFree(z);
    }
    while( azSeries[0] ){
      z = Trim(azSeries[0]);
      if( z ){
        Tcl_DStringAppendElement(&cmd, z);
        HtmlFree(z);
      }
      azSeries++;
    }
    HtmlLock(htmlPtr);
    rc = Tcl_GlobalEval(htmlPtr->interp, Tcl_DStringValue(&cmd));
    Tcl_DStringFree(&cmd);
    if( HtmlUnlock(htmlPtr) ) return TCL_ERROR;
    if( rc!=TCL_OK ){
      Tcl_AddErrorInfo(htmlPtr->interp,
         "\n    (-resolvercommand executed by HTML widget)");
    }
  }else{
    /*
    ** No -resolvercommand has been specified.  Do the default
    ** resolver algorithm specified in section 5.2 of RFC 2396.
    */
    HtmlUri *base, *term;
    if( htmlPtr->zBaseHref && htmlPtr->zBaseHref[0] ){
      base = ParseUri(htmlPtr->zBaseHref);
    }else{
      base = ParseUri(htmlPtr->zBase);
    }
    while( azSeries[0] ){
      term = ParseUri(azSeries[0]);
      azSeries++;
      if( term->zScheme==0 && term->zAuthority==0 && term->zPath==0
          && term->zQuery==0 && term->zFragment ){
        ReplaceStr(&base->zFragment, term->zFragment);
      }else if( term->zScheme ){
        HtmlUri temp;
        temp = *term;
        *term = *base;
        *base = temp;
      }else if( term->zAuthority ){
        ReplaceStr(&base->zAuthority, term->zAuthority);
        ReplaceStr(&base->zPath, term->zPath);
        ReplaceStr(&base->zQuery, term->zQuery);
        ReplaceStr(&base->zFragment, term->zFragment);
      }else if( term->zPath && (term->zPath[0]=='/' || base->zPath==0) ){
        ReplaceStr(&base->zPath, term->zPath);
        ReplaceStr(&base->zQuery, term->zQuery);
        ReplaceStr(&base->zFragment, term->zFragment);
      }else if( term->zPath && base->zPath ){
        char *zBuf;
        int i, j;
        zBuf = HtmlAlloc( strlen(base->zPath) + strlen(term->zPath) + 2 );
        if( zBuf ){
          sprintf(zBuf,"%s", base->zPath);
          for(i=strlen(zBuf)-1; i>=0 && zBuf[i]!='/'; i--){ zBuf[i] = 0; }
          strcat(zBuf, term->zPath);
          for(i=0; zBuf[i]; i++){
            if( zBuf[i]=='/' && zBuf[i+1]=='.' && zBuf[i+2]=='/' ){
              strcpy(&zBuf[i+1], &zBuf[i+3]);
              i--;
              continue;
            }
            if( zBuf[i]=='/' && zBuf[i+1]=='.' && zBuf[i+2]==0 ){
              zBuf[i+1] = 0;
              continue;
            }
            if( i>0 && zBuf[i]=='/' && zBuf[i+1]=='.' && zBuf[i+2]=='.'
                   && (zBuf[i+3]=='/' || zBuf[i+3]==0) ){
              for(j=i-1; j>=0 && zBuf[j]!='/'; j--){}
              if( zBuf[i+3] ){
                strcpy(&zBuf[j+1], &zBuf[i+4]);
              }else{
                zBuf[j+1] = 0;
              }
              i = j-1;
              if( i<-1 ) i = -1;
              continue;
            }
          }
          HtmlFree(base->zPath);
          base->zPath = zBuf;
        }
        ReplaceStr(&base->zQuery, term->zQuery);
        ReplaceStr(&base->zFragment, term->zFragment);
     }
      FreeUri(term);
    }
    Tcl_SetResult(htmlPtr->interp, BuildUri(base), TCL_DYNAMIC);
    FreeUri(base);
  }
  return rc;
}