/* 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; }
/* *-------------------------------------------------------------- * * 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; }
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 }
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; }
/* 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; }
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 (); }
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); } }
/* 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; }
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); } }
/* 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; }
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; }
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; }
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; }
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; }
/** @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); }
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); }
/* ** 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; }
/* *---------------------------------------------------------------------- * * 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; }
/* ** 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); }
/******************************************************************************************** * 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]); }
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; }
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); } }
/* * ------------------------------------------------------------------------ * 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); }
/*----------------------------------------------------------------------------- * 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; }
/* 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; }
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; }
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; }
/* * ------------------------------------------------------------------------ * 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; }
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; }
/* ** 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; }