/* discover the sequencer devices currently available */ static int alsa_sequencer_list(ClientData clientData, Tcl_Interp *interp) { snd_seq_client_info_t *cinfo; snd_seq_port_info_t *pinfo; Tcl_Obj *result = Tcl_NewListObj(0, NULL); if (init_seq(clientData, interp) != TCL_OK) { return TCL_ERROR; } snd_seq_client_info_alloca(&cinfo); snd_seq_port_info_alloca(&pinfo); snd_seq_client_info_set_client(cinfo, -1); while (snd_seq_query_next_client(seq, cinfo) >= 0) { int client = snd_seq_client_info_get_client(cinfo); snd_seq_port_info_set_client(pinfo, client); snd_seq_port_info_set_port(pinfo, -1); while (snd_seq_query_next_port(seq, pinfo) >= 0) { /* we need both READ and SUBS_READ */ int capability = snd_seq_port_info_get_capability(pinfo); char *readable = ((capability & (SND_SEQ_PORT_CAP_READ | SND_SEQ_PORT_CAP_SUBS_READ)) == (SND_SEQ_PORT_CAP_READ | SND_SEQ_PORT_CAP_SUBS_READ)) ? "r" : ""; char *writable = ((capability & (SND_SEQ_PORT_CAP_WRITE | SND_SEQ_PORT_CAP_SUBS_WRITE)) == (SND_SEQ_PORT_CAP_WRITE | SND_SEQ_PORT_CAP_SUBS_WRITE)) ? "w" : ""; Tcl_Obj *element = Tcl_ObjPrintf("%3d:%-3d %-32.32s %s %s%s", snd_seq_port_info_get_client(pinfo), snd_seq_port_info_get_port(pinfo), snd_seq_client_info_get_name(cinfo), snd_seq_port_info_get_name(pinfo), readable, writable); Tcl_ListObjAppendElement(interp, result, element); } } Tcl_SetObjResult(interp, result); return TCL_OK; }
static int ScaleWidgetObjCmd( ClientData clientData, /* Information about scale widget. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { TkScale *scalePtr = clientData; Tcl_Obj *objPtr; int index, result; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } result = Tcl_GetIndexFromObj(interp, objv[1], commandNames, "option", 0, &index); if (result != TCL_OK) { return result; } Tcl_Preserve(scalePtr); switch (index) { case COMMAND_CGET: if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "cget option"); goto error; } objPtr = Tk_GetOptionValue(interp, (char *) scalePtr, scalePtr->optionTable, objv[2], scalePtr->tkwin); if (objPtr == NULL) { goto error; } Tcl_SetObjResult(interp, objPtr); break; case COMMAND_CONFIGURE: if (objc <= 3) { objPtr = Tk_GetOptionInfo(interp, (char *) scalePtr, scalePtr->optionTable, (objc == 3) ? objv[2] : NULL, scalePtr->tkwin); if (objPtr == NULL) { goto error; } Tcl_SetObjResult(interp, objPtr); } else { result = ConfigureScale(interp, scalePtr, objc-2, objv+2); } break; case COMMAND_COORDS: { int x, y; double value; Tcl_Obj *coords[2]; if ((objc != 2) && (objc != 3)) { Tcl_WrongNumArgs(interp, 1, objv, "coords ?value?"); goto error; } if (objc == 3) { if (Tcl_GetDoubleFromObj(interp, objv[2], &value) != TCL_OK) { goto error; } } else { value = scalePtr->value; } if (scalePtr->orient == ORIENT_VERTICAL) { x = scalePtr->vertTroughX + scalePtr->width/2 + scalePtr->borderWidth; y = TkScaleValueToPixel(scalePtr, value); } else { x = TkScaleValueToPixel(scalePtr, value); y = scalePtr->horizTroughY + scalePtr->width/2 + scalePtr->borderWidth; } coords[0] = Tcl_NewIntObj(x); coords[1] = Tcl_NewIntObj(y); Tcl_SetObjResult(interp, Tcl_NewListObj(2, coords)); break; } case COMMAND_GET: { double value; int x, y; if ((objc != 2) && (objc != 4)) { Tcl_WrongNumArgs(interp, 1, objv, "get ?x y?"); goto error; } if (objc == 2) { value = scalePtr->value; } else { if ((Tcl_GetIntFromObj(interp, objv[2], &x) != TCL_OK) || (Tcl_GetIntFromObj(interp, objv[3], &y) != TCL_OK)) { goto error; } value = TkScalePixelToValue(scalePtr, x, y); } Tcl_SetObjResult(interp, Tcl_ObjPrintf(scalePtr->format, value)); break; } case COMMAND_IDENTIFY: { int x, y; const char *zone = ""; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "identify x y"); goto error; } if ((Tcl_GetIntFromObj(interp, objv[2], &x) != TCL_OK) || (Tcl_GetIntFromObj(interp, objv[3], &y) != TCL_OK)) { goto error; } switch (TkpScaleElement(scalePtr, x, y)) { case TROUGH1: zone = "trough1"; break; case SLIDER: zone = "slider"; break; case TROUGH2: zone = "trough2"; break; } Tcl_SetObjResult(interp, Tcl_NewStringObj(zone, -1)); break; } case COMMAND_SET: { double value; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "set value"); goto error; } if (Tcl_GetDoubleFromObj(interp, objv[2], &value) != TCL_OK) { goto error; } if (scalePtr->state != STATE_DISABLED) { TkScaleSetValue(scalePtr, value, 1, 1); } break; } } Tcl_Release(scalePtr); return result; error: Tcl_Release(scalePtr); return TCL_ERROR; }
int TclpMatchInDirectory( Tcl_Interp *interp, /* Interpreter to receive errors. */ Tcl_Obj *resultPtr, /* List object to lappend results. */ Tcl_Obj *pathPtr, /* Contains path to directory to search. */ const char *pattern, /* Pattern to match against. */ Tcl_GlobTypeData *types) /* Object containing list of acceptable types. * May be NULL. In particular the directory * flag is very important. */ { const char *native; Tcl_Obj *fileNamePtr; int matchResult = 0; if (types != NULL && types->type == TCL_GLOB_TYPE_MOUNT) { /* * The native filesystem never adds mounts. */ return TCL_OK; } fileNamePtr = Tcl_FSGetTranslatedPath(interp, pathPtr); if (fileNamePtr == NULL) { return TCL_ERROR; } if (pattern == NULL || (*pattern == '\0')) { /* * Match a file directly. */ Tcl_Obj *tailPtr; const char *nativeTail; native = Tcl_FSGetNativePath(pathPtr); tailPtr = TclPathPart(interp, pathPtr, TCL_PATH_TAIL); nativeTail = Tcl_FSGetNativePath(tailPtr); matchResult = NativeMatchType(interp, native, nativeTail, types); if (matchResult == 1) { Tcl_ListObjAppendElement(interp, resultPtr, pathPtr); } Tcl_DecrRefCount(tailPtr); Tcl_DecrRefCount(fileNamePtr); } else { DIR *d; Tcl_DirEntry *entryPtr; const char *dirName; int dirLength, nativeDirLen; int matchHidden, matchHiddenPat; Tcl_StatBuf statBuf; Tcl_DString ds; /* native encoding of dir */ Tcl_DString dsOrig; /* utf-8 encoding of dir */ Tcl_DStringInit(&dsOrig); dirName = TclGetStringFromObj(fileNamePtr, &dirLength); Tcl_DStringAppend(&dsOrig, dirName, dirLength); /* * Make sure that the directory part of the name really is a * directory. If the directory name is "", use the name "." instead, * because some UNIX systems don't treat "" like "." automatically. * Keep the "" for use in generating file names, otherwise "glob * foo.c" would return "./foo.c". */ if (dirLength == 0) { dirName = "."; } else { dirName = Tcl_DStringValue(&dsOrig); /* * Make sure we have a trailing directory delimiter. */ if (dirName[dirLength-1] != '/') { dirName = TclDStringAppendLiteral(&dsOrig, "/"); dirLength++; } } /* * Now open the directory for reading and iterate over the contents. */ native = Tcl_UtfToExternalDString(NULL, dirName, -1, &ds); if ((TclOSstat(native, &statBuf) != 0) /* INTL: Native. */ || !S_ISDIR(statBuf.st_mode)) { Tcl_DStringFree(&dsOrig); Tcl_DStringFree(&ds); Tcl_DecrRefCount(fileNamePtr); return TCL_OK; } d = opendir(native); /* INTL: Native. */ if (d == NULL) { Tcl_DStringFree(&ds); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read directory \"%s\": %s", Tcl_DStringValue(&dsOrig), Tcl_PosixError(interp))); } Tcl_DStringFree(&dsOrig); Tcl_DecrRefCount(fileNamePtr); return TCL_ERROR; } nativeDirLen = Tcl_DStringLength(&ds); /* * Check to see if -type or the pattern requests hidden files. */ matchHiddenPat = (pattern[0] == '.') || ((pattern[0] == '\\') && (pattern[1] == '.')); matchHidden = matchHiddenPat || (types && (types->perm & TCL_GLOB_PERM_HIDDEN)); while ((entryPtr = TclOSreaddir(d)) != NULL) { /* INTL: Native. */ Tcl_DString utfDs; const char *utfname; /* * Skip this file if it doesn't agree with the hidden parameters * requested by the user (via -type or pattern). */ if (*entryPtr->d_name == '.') { if (!matchHidden) { continue; } } else { #ifdef MAC_OSX_TCL if (matchHiddenPat) { continue; } /* Also need to check HFS hidden flag in TclMacOSXMatchType. */ #else if (matchHidden) { continue; } #endif } /* * Now check to see if the file matches, according to both type * and pattern. If so, add the file to the result. */ utfname = Tcl_ExternalToUtfDString(NULL, entryPtr->d_name, -1, &utfDs); if (Tcl_StringCaseMatch(utfname, pattern, 0)) { int typeOk = 1; if (types != NULL) { Tcl_DStringSetLength(&ds, nativeDirLen); native = Tcl_DStringAppend(&ds, entryPtr->d_name, -1); matchResult = NativeMatchType(interp, native, entryPtr->d_name, types); typeOk = (matchResult == 1); } if (typeOk) { Tcl_ListObjAppendElement(interp, resultPtr, TclNewFSPathObj(pathPtr, utfname, Tcl_DStringLength(&utfDs))); } } Tcl_DStringFree(&utfDs); if (matchResult < 0) { break; } } closedir(d); Tcl_DStringFree(&ds); Tcl_DStringFree(&dsOrig); Tcl_DecrRefCount(fileNamePtr); } if (matchResult < 0) { return TCL_ERROR; } return TCL_OK; }
Tcl_Channel Tcl_OpenTcpClient( Tcl_Interp *interp, /* For error reporting; can be NULL. */ int port, /* Port number to open. */ const char *host, /* Host on which to open port. */ const char *myaddr, /* Client-side address */ int myport, /* Client-side port */ int async) /* If nonzero, attempt to do an asynchronous * connect. Otherwise we do a blocking * connect. */ { TcpState *statePtr; const char *errorMsg = NULL; struct addrinfo *addrlist = NULL, *myaddrlist = NULL; char channelName[SOCK_CHAN_LENGTH]; /* * Do the name lookups for the local and remote addresses. */ if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg) || !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, &errorMsg)) { if (addrlist != NULL) { freeaddrinfo(addrlist); } if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open socket: %s", errorMsg)); } return NULL; } /* * Allocate a new TcpState for this socket. */ statePtr = ckalloc(sizeof(TcpState)); memset(statePtr, 0, sizeof(TcpState)); statePtr->flags = async ? TCP_ASYNC_CONNECT : 0; statePtr->cachedBlocking = TCL_MODE_BLOCKING; statePtr->addrlist = addrlist; statePtr->myaddrlist = myaddrlist; statePtr->fds.fd = -1; /* * Create a new client socket and wrap it in a channel. */ if (TcpConnect(interp, statePtr) != TCL_OK) { TcpCloseProc(statePtr, NULL); return NULL; } sprintf(channelName, SOCK_TEMPLATE, (long) statePtr); statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName, statePtr, (TCL_READABLE | TCL_WRITABLE)); if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation", "auto crlf") == TCL_ERROR) { Tcl_Close(NULL, statePtr->channel); return NULL; } return statePtr->channel; }
static int ConfigureSlave( Tcl_Interp *interp, /* Used for error reporting. */ Tk_Window tkwin, /* Token for the window to manipulate. */ Tk_OptionTable table, /* Token for option table. */ int objc, /* Number of config arguments. */ Tcl_Obj *const objv[]) /* Object values for arguments. */ { register Master *masterPtr; Tk_SavedOptions savedOptions; int mask; Slave *slavePtr; Tk_Window masterWin = (Tk_Window) NULL; if (Tk_TopWinHierarchy(tkwin)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use placer on top-level window \"%s\"; use " "wm command instead", Tk_PathName(tkwin))); Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "TOPLEVEL", NULL); return TCL_ERROR; } slavePtr = CreateSlave(tkwin, table); if (Tk_SetOptions(interp, (char *) slavePtr, table, objc, objv, slavePtr->tkwin, &savedOptions, &mask) != TCL_OK) { goto error; } /* * Set slave flags. First clear the field, then add bits as needed. */ slavePtr->flags = 0; if (slavePtr->heightPtr) { slavePtr->flags |= CHILD_HEIGHT; } if (slavePtr->relHeightPtr) { slavePtr->flags |= CHILD_REL_HEIGHT; } if (slavePtr->relWidthPtr) { slavePtr->flags |= CHILD_REL_WIDTH; } if (slavePtr->widthPtr) { slavePtr->flags |= CHILD_WIDTH; } if (!(mask & IN_MASK) && (slavePtr->masterPtr != NULL)) { /* * If no -in option was passed and the slave is already placed then * just recompute the placement. */ masterPtr = slavePtr->masterPtr; goto scheduleLayout; } else if (mask & IN_MASK) { /* -in changed */ Tk_Window tkwin; Tk_Window ancestor; tkwin = slavePtr->inTkwin; /* * Make sure that the new master is either the logical parent of the * slave or a descendant of that window, and that the master and slave * aren't the same. */ for (ancestor = tkwin; ; ancestor = Tk_Parent(ancestor)) { if (ancestor == Tk_Parent(slavePtr->tkwin)) { break; } if (Tk_TopWinHierarchy(ancestor)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't place %s relative to %s", Tk_PathName(slavePtr->tkwin), Tk_PathName(tkwin))); Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "HIERARCHY", NULL); goto error; } } if (slavePtr->tkwin == tkwin) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't place %s relative to itself", Tk_PathName(slavePtr->tkwin))); Tcl_SetErrorCode(interp, "TK", "GEOMETRY", "LOOP", NULL); goto error; } if ((slavePtr->masterPtr != NULL) && (slavePtr->masterPtr->tkwin == tkwin)) { /* * Re-using same old master. Nothing to do. */ masterPtr = slavePtr->masterPtr; goto scheduleLayout; } if ((slavePtr->masterPtr != NULL) && (slavePtr->masterPtr->tkwin != Tk_Parent(slavePtr->tkwin))) { Tk_UnmaintainGeometry(slavePtr->tkwin, slavePtr->masterPtr->tkwin); } UnlinkSlave(slavePtr); masterWin = tkwin; } /* * If there's no master specified for this slave, use its Tk_Parent. */ if (masterWin == NULL) { masterWin = Tk_Parent(slavePtr->tkwin); slavePtr->inTkwin = masterWin; } /* * Manage the slave window in this master. */ masterPtr = CreateMaster(masterWin); slavePtr->masterPtr = masterPtr; slavePtr->nextPtr = masterPtr->slavePtr; masterPtr->slavePtr = slavePtr; Tk_ManageGeometry(slavePtr->tkwin, &placerType, slavePtr); /* * Arrange for the master to be re-arranged at the first idle moment. */ scheduleLayout: Tk_FreeSavedOptions(&savedOptions); if (!(masterPtr->flags & PARENT_RECONFIG_PENDING)) { masterPtr->flags |= PARENT_RECONFIG_PENDING; Tcl_DoWhenIdle(RecomputePlacement, masterPtr); } return TCL_OK; /* * Error while processing some option, cleanup and return. */ error: Tk_RestoreSavedOptions(&savedOptions); return TCL_ERROR; }
int Tcl_ParseArgsObjv( Tcl_Interp *interp, /* Place to store error message. */ const Tcl_ArgvInfo *argTable, /* Array of option descriptions. */ int *objcPtr, /* Number of arguments in objv. Modified to * hold # args left in objv at end. */ Tcl_Obj *const *objv, /* Array of arguments to be parsed. */ Tcl_Obj ***remObjv) /* Pointer to array of arguments that were not * processed here. Should be NULL if no return * of arguments is desired. */ { Tcl_Obj **leftovers; /* Array to write back to remObjv on * successful exit. Will include the name of * the command. */ int nrem; /* Size of leftovers.*/ register const Tcl_ArgvInfo *infoPtr; /* Pointer to the current entry in the table * of argument descriptions. */ const Tcl_ArgvInfo *matchPtr; /* Descriptor that matches current argument */ Tcl_Obj *curArg; /* Current argument */ const char *str = NULL; register char c; /* Second character of current arg (used for * quick check for matching; use 2nd char. * because first char. will almost always be * '-'). */ int srcIndex; /* Location from which to read next argument * from objv. */ int dstIndex; /* Used to keep track of current arguments * being processed, primarily for error * reporting. */ int objc; /* # arguments in objv still to process. */ int length; /* Number of characters in current argument */ if (remObjv != NULL) { /* * Then we should copy the name of the command (0th argument). The * upper bound on the number of elements is known, and (undocumented, * but historically true) there should be a NULL argument after the * last result. [Bug 3413857] */ nrem = 1; leftovers = ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *)); leftovers[0] = objv[0]; } else { nrem = 0; leftovers = NULL; } /* * OK, now start processing from the second element (1st argument). */ srcIndex = dstIndex = 1; objc = *objcPtr-1; while (objc > 0) { curArg = objv[srcIndex]; srcIndex++; objc--; str = Tcl_GetStringFromObj(curArg, &length); if (length > 0) { c = str[1]; } else { c = 0; } /* * Loop throught the argument descriptors searching for one with the * matching key string. If found, leave a pointer to it in matchPtr. */ matchPtr = NULL; infoPtr = argTable; for (; infoPtr != NULL && infoPtr->type != TCL_ARGV_END ; infoPtr++) { if (infoPtr->keyStr == NULL) { continue; } if ((infoPtr->keyStr[1] != c) || (strncmp(infoPtr->keyStr, str, length) != 0)) { continue; } if (infoPtr->keyStr[length] == 0) { matchPtr = infoPtr; goto gotMatch; } if (matchPtr != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "ambiguous option \"%s\"", str)); goto error; } matchPtr = infoPtr; } if (matchPtr == NULL) { /* * Unrecognized argument. Just copy it down, unless the caller * prefers an error to be registered. */ if (remObjv == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unrecognized argument \"%s\"", str)); goto error; } dstIndex++; /* This argument is now handled */ leftovers[nrem++] = curArg; continue; } /* * Take the appropriate action based on the option type */ gotMatch: infoPtr = matchPtr; switch (infoPtr->type) { case TCL_ARGV_CONSTANT: *((int *) infoPtr->dstPtr) = PTR2INT(infoPtr->srcPtr); break; case TCL_ARGV_INT: if (objc == 0) { goto missingArg; } if (Tcl_GetIntFromObj(interp, objv[srcIndex], (int *) infoPtr->dstPtr) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer argument for \"%s\" but got \"%s\"", infoPtr->keyStr, Tcl_GetString(objv[srcIndex]))); goto error; } srcIndex++; objc--; break; case TCL_ARGV_STRING: if (objc == 0) { goto missingArg; } *((const char **) infoPtr->dstPtr) = Tcl_GetString(objv[srcIndex]); srcIndex++; objc--; break; case TCL_ARGV_REST: /* * Only store the point where we got to if it's not to be written * to NULL, so that TCL_ARGV_AUTO_REST works. */ if (infoPtr->dstPtr != NULL) { *((int *) infoPtr->dstPtr) = dstIndex; } goto argsDone; case TCL_ARGV_FLOAT: if (objc == 0) { goto missingArg; } if (Tcl_GetDoubleFromObj(interp, objv[srcIndex], (double *) infoPtr->dstPtr) == TCL_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected floating-point argument for \"%s\" but got \"%s\"", infoPtr->keyStr, Tcl_GetString(objv[srcIndex]))); goto error; } srcIndex++; objc--; break; case TCL_ARGV_FUNC: { Tcl_ArgvFuncProc *handlerProc = (Tcl_ArgvFuncProc *) infoPtr->srcPtr; Tcl_Obj *argObj; if (objc == 0) { argObj = NULL; } else { argObj = objv[srcIndex]; } if (handlerProc(infoPtr->clientData, argObj, infoPtr->dstPtr)) { srcIndex++; objc--; } break; } case TCL_ARGV_GENFUNC: { Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *) infoPtr->srcPtr; objc = handlerProc(infoPtr->clientData, interp, objc, &objv[srcIndex], infoPtr->dstPtr); if (objc < 0) { goto error; } break; } case TCL_ARGV_HELP: PrintUsage(interp, argTable); goto error; default: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument type %d in Tcl_ArgvInfo", infoPtr->type)); goto error; } } /* * If we broke out of the loop because of an OPT_REST argument, copy the * remaining arguments down. Note that there is always at least one * argument left over - the command name - so we always have a result if * our caller is willing to receive it. [Bug 3413857] */ argsDone: if (remObjv == NULL) { /* * Nothing to do. */ return TCL_OK; } if (objc > 0) { memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *)); nrem += objc; } leftovers[nrem] = NULL; *objcPtr = nrem++; *remObjv = ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *)); return TCL_OK; /* * Make sure to handle freeing any temporary space we've allocated on the * way to an error. */ missingArg: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" option requires an additional argument", str)); error: if (leftovers != NULL) { ckfree(leftovers); } return TCL_ERROR; }
int TkOffsetParseProc( ClientData clientData, /* not used */ Tcl_Interp *interp, /* Interpreter to send results back to */ Tk_Window tkwin, /* Window on same display as tile */ const char *value, /* Name of image */ char *widgRec, /* Widget structure record */ int offset) /* Offset of tile in record */ { Tk_TSOffset *offsetPtr = (Tk_TSOffset *) (widgRec + offset); Tk_TSOffset tsoffset; const char *q, *p; int result; Tcl_Obj *msgObj; if ((value == NULL) || (*value == 0)) { tsoffset.flags = TK_OFFSET_CENTER|TK_OFFSET_MIDDLE; goto goodTSOffset; } tsoffset.flags = 0; p = value; switch (value[0]) { case '#': if (PTR2INT(clientData) & TK_OFFSET_RELATIVE) { tsoffset.flags = TK_OFFSET_RELATIVE; p++; break; } goto badTSOffset; case 'e': switch(value[1]) { case '\0': tsoffset.flags = TK_OFFSET_RIGHT|TK_OFFSET_MIDDLE; goto goodTSOffset; case 'n': if (value[2]!='d' || value[3]!='\0') { goto badTSOffset; } tsoffset.flags = INT_MAX; goto goodTSOffset; } case 'w': if (value[1] != '\0') {goto badTSOffset;} tsoffset.flags = TK_OFFSET_LEFT|TK_OFFSET_MIDDLE; goto goodTSOffset; case 'n': if ((value[1] != '\0') && (value[2] != '\0')) { goto badTSOffset; } switch(value[1]) { case '\0': tsoffset.flags = TK_OFFSET_CENTER|TK_OFFSET_TOP; goto goodTSOffset; case 'w': tsoffset.flags = TK_OFFSET_LEFT|TK_OFFSET_TOP; goto goodTSOffset; case 'e': tsoffset.flags = TK_OFFSET_RIGHT|TK_OFFSET_TOP; goto goodTSOffset; } goto badTSOffset; case 's': if ((value[1] != '\0') && (value[2] != '\0')) { goto badTSOffset; } switch(value[1]) { case '\0': tsoffset.flags = TK_OFFSET_CENTER|TK_OFFSET_BOTTOM; goto goodTSOffset; case 'w': tsoffset.flags = TK_OFFSET_LEFT|TK_OFFSET_BOTTOM; goto goodTSOffset; case 'e': tsoffset.flags = TK_OFFSET_RIGHT|TK_OFFSET_BOTTOM; goto goodTSOffset; } goto badTSOffset; case 'c': if (strncmp(value, "center", strlen(value)) != 0) { goto badTSOffset; } tsoffset.flags = TK_OFFSET_CENTER|TK_OFFSET_MIDDLE; goto goodTSOffset; } /* * Check for an extra offset. */ q = strchr(p, ','); if (q == NULL) { if (PTR2INT(clientData) & TK_OFFSET_INDEX) { if (Tcl_GetInt(interp, (char *) p, &tsoffset.flags) != TCL_OK) { Tcl_ResetResult(interp); goto badTSOffset; } tsoffset.flags |= TK_OFFSET_INDEX; goto goodTSOffset; } goto badTSOffset; } *((char *) q) = 0; result = Tk_GetPixels(interp, tkwin, (char *) p, &tsoffset.xoffset); *((char *) q) = ','; if (result != TCL_OK) { return TCL_ERROR; } if (Tk_GetPixels(interp, tkwin, (char*)q+1, &tsoffset.yoffset) != TCL_OK) { return TCL_ERROR; } /* * Below is a hack to allow the stipple/tile offset to be stored in the * internal tile structure. Most of the times, offsetPtr is a pointer to * an already existing tile structure. However if this structure is not * already created, we must do it with Tk_GetTile()!!!! */ goodTSOffset: memcpy(offsetPtr, &tsoffset, sizeof(Tk_TSOffset)); return TCL_OK; badTSOffset: msgObj = Tcl_ObjPrintf("bad offset \"%s\": expected \"x,y\"", value); if (PTR2INT(clientData) & TK_OFFSET_RELATIVE) { Tcl_AppendToObj(msgObj, ", \"#x,y\"", -1); } if (PTR2INT(clientData) & TK_OFFSET_INDEX) { Tcl_AppendToObj(msgObj, ", <index>", -1); } Tcl_AppendToObj(msgObj, ", n, ne, e, se, s, sw, w, nw, or center", -1); Tcl_SetObjResult(interp, msgObj); Tcl_SetErrorCode(interp, "TK", "VALUE", "OFFSET", NULL); return TCL_ERROR; }
static int RectOvalCoords( Tcl_Interp *interp, /* Used for error reporting. */ Tk_Canvas canvas, /* Canvas containing item. */ Tk_Item *itemPtr, /* Item whose coordinates are to be read or * modified. */ int objc, /* Number of coordinates supplied in objv. */ Tcl_Obj *const objv[]) /* Array of coordinates: x1,y1,x2,y2,... */ { RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; /* * If no coordinates, return the current coordinates (i.e. bounding box). */ if (objc == 0) { Tcl_Obj *bbox[4]; bbox[0] = Tcl_NewDoubleObj(rectOvalPtr->bbox[0]); bbox[1] = Tcl_NewDoubleObj(rectOvalPtr->bbox[1]); bbox[2] = Tcl_NewDoubleObj(rectOvalPtr->bbox[2]); bbox[3] = Tcl_NewDoubleObj(rectOvalPtr->bbox[3]); Tcl_SetObjResult(interp, Tcl_NewListObj(4, bbox)); return TCL_OK; } /* * If one "coordinate", treat as list of coordinates. */ if (objc == 1) { if (Tcl_ListObjGetElements(interp, objv[0], &objc, (Tcl_Obj ***) &objv) != TCL_OK) { return TCL_ERROR; } } /* * Better have four coordinates now. Spit out an error message otherwise. */ if (objc != 4) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "wrong # coordinates: expected 0 or 4, got %d", objc)); Tcl_SetErrorCode(interp, "TK", "CANVAS", "COORDS", (rectOvalPtr->header.typePtr == &tkRectangleType ? "RECTANGLE" : "OVAL"), NULL); return TCL_ERROR; } /* * Parse the coordinates and update our bounding box. */ if ((Tk_CanvasGetCoordFromObj(interp, canvas, objv[0], &rectOvalPtr->bbox[0]) != TCL_OK) || (Tk_CanvasGetCoordFromObj(interp, canvas, objv[1], &rectOvalPtr->bbox[1]) != TCL_OK) || (Tk_CanvasGetCoordFromObj(interp, canvas, objv[2], &rectOvalPtr->bbox[2]) != TCL_OK) || (Tk_CanvasGetCoordFromObj(interp, canvas, objv[3], &rectOvalPtr->bbox[3]) != TCL_OK)) { return TCL_ERROR; } ComputeRectOvalBbox(canvas, rectOvalPtr); return TCL_OK; }
static TkBitmap * GetBitmap( Tcl_Interp *interp, /* Interpreter to use for error reporting, * this may be NULL. */ Tk_Window tkwin, /* Window in which bitmap will be used. */ const char *string) /* Description of bitmap. See manual entry for * details on legal syntax. */ { Tcl_HashEntry *nameHashPtr, *predefHashPtr; TkBitmap *bitmapPtr, *existingBitmapPtr; TkPredefBitmap *predefPtr; Pixmap bitmap; int isNew, width, height, dummy2; TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); if (!dispPtr->bitmapInit) { BitmapInit(dispPtr); } nameHashPtr = Tcl_CreateHashEntry(&dispPtr->bitmapNameTable, string, &isNew); if (!isNew) { existingBitmapPtr = Tcl_GetHashValue(nameHashPtr); for (bitmapPtr = existingBitmapPtr; bitmapPtr != NULL; bitmapPtr = bitmapPtr->nextPtr) { if ((Tk_Display(tkwin) == bitmapPtr->display) && (Tk_ScreenNumber(tkwin) == bitmapPtr->screenNum)) { bitmapPtr->resourceRefCount++; return bitmapPtr; } } } else { existingBitmapPtr = NULL; } /* * No suitable bitmap exists. Create a new bitmap from the information * contained in the string. If the string starts with "@" then the rest of * the string is a file name containing the bitmap. Otherwise the string * must refer to a bitmap defined by a call to Tk_DefineBitmap. */ if (*string == '@') { /* INTL: ISO char */ Tcl_DString buffer; int result; if (Tcl_IsSafe(interp)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't specify bitmap with '@' in a safe interpreter", -1)); Tcl_SetErrorCode(interp, "TK", "SAFE", "BITMAP_FILE", NULL); goto error; } /* * Note that we need to cast away the const from the string because * Tcl_TranslateFileName is non-const, even though it doesn't modify * the string. */ string = Tcl_TranslateFileName(interp, (char *) string + 1, &buffer); if (string == NULL) { goto error; } result = TkReadBitmapFile(Tk_Display(tkwin), RootWindowOfScreen(Tk_Screen(tkwin)), string, (unsigned int *) &width, (unsigned int *) &height, &bitmap, &dummy2, &dummy2); if (result != BitmapSuccess) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error reading bitmap file \"%s\"", string)); Tcl_SetErrorCode(interp, "TK", "BITMAP", "FILE_ERROR", NULL); } Tcl_DStringFree(&buffer); goto error; } Tcl_DStringFree(&buffer); } else { predefHashPtr = Tcl_FindHashEntry(&tsdPtr->predefBitmapTable, string); if (predefHashPtr == NULL) { /* * The following platform specific call allows the user to define * bitmaps that may only exist during run time. If it returns None * nothing was found and we return the error. */ bitmap = TkpGetNativeAppBitmap(Tk_Display(tkwin), string, &width, &height); if (bitmap == None) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bitmap \"%s\" not defined", string)); Tcl_SetErrorCode(interp, "TK", "LOOKUP", "BITMAP", string, NULL); } goto error; } } else { predefPtr = Tcl_GetHashValue(predefHashPtr); width = predefPtr->width; height = predefPtr->height; if (predefPtr->native) { bitmap = TkpCreateNativeBitmap(Tk_Display(tkwin), predefPtr->source); if (bitmap == None) { Tcl_Panic("native bitmap creation failed"); } } else { bitmap = XCreateBitmapFromData(Tk_Display(tkwin), RootWindowOfScreen(Tk_Screen(tkwin)), predefPtr->source, (unsigned)width, (unsigned)height); } } } /* * Add information about this bitmap to our database. */ bitmapPtr = ckalloc(sizeof(TkBitmap)); bitmapPtr->bitmap = bitmap; bitmapPtr->width = width; bitmapPtr->height = height; bitmapPtr->display = Tk_Display(tkwin); bitmapPtr->screenNum = Tk_ScreenNumber(tkwin); bitmapPtr->resourceRefCount = 1; bitmapPtr->objRefCount = 0; bitmapPtr->nameHashPtr = nameHashPtr; bitmapPtr->idHashPtr = Tcl_CreateHashEntry(&dispPtr->bitmapIdTable, (char *) bitmap, &isNew); if (!isNew) { Tcl_Panic("bitmap already registered in Tk_GetBitmap"); } bitmapPtr->nextPtr = existingBitmapPtr; Tcl_SetHashValue(nameHashPtr, bitmapPtr); Tcl_SetHashValue(bitmapPtr->idHashPtr, bitmapPtr); return bitmapPtr; error: if (isNew) { Tcl_DeleteHashEntry(nameHashPtr); } return NULL; }
int TkpUseWindow( Tcl_Interp *interp, /* If not NULL, used for error reporting if * string is bogus. */ Tk_Window tkwin, /* Tk window that does not yet have an * associated X window. */ const char *string) /* String identifying an X window to use for * tkwin; must be an integer value. */ { TkWindow *winPtr = (TkWindow *) tkwin; TkWindow *usePtr; MacDrawable *parent, *macWin; Container *containerPtr; if (winPtr->window != None) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't modify container after widget is created", -1)); Tcl_SetErrorCode(interp, "TK", "EMBED", "POST_CREATE", NULL); return TCL_ERROR; } /* * Decode the container window ID, and look for it among the list of * available containers. * * N.B. For now, we are limiting the containers to be in the same Tk * application as tkwin, since otherwise they would not be in our list of * containers. */ if (TkpScanWindowId(interp, string, (Window *)&parent) != TCL_OK) { return TCL_ERROR; } usePtr = (TkWindow *) Tk_IdToWindow(winPtr->display, (Window) parent); if (usePtr != NULL && !(usePtr->flags & TK_CONTAINER)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" doesn't have -container option set", usePtr->pathName)); Tcl_SetErrorCode(interp, "TK", "EMBED", "CONTAINER", NULL); return TCL_ERROR; } /* * The code below can probably be simplified given we have already * discovered 'usePtr' above. */ /* * Save information about the container and the embedded window in a * Container structure. Currently, there must already be an existing * Container structure, since we only allow the case where both container * and embedded app. are in the same process. */ for (containerPtr = firstContainerPtr; containerPtr != NULL; containerPtr = containerPtr->nextPtr) { if (containerPtr->parent == (Window) parent) { winPtr->flags |= TK_BOTH_HALVES; containerPtr->parentPtr->flags |= TK_BOTH_HALVES; break; } } /* * Make the embedded window. */ macWin = ckalloc(sizeof(MacDrawable)); if (macWin == NULL) { winPtr->privatePtr = NULL; return TCL_ERROR; } macWin->winPtr = winPtr; winPtr->privatePtr = macWin; /* * The grafPtr will be NULL for a Tk in Tk embedded window. It is none of * our business what it is for a Tk not in Tk embedded window, but we will * initialize it to NULL, and let the registerWinProc set it. In any case, * you must always use TkMacOSXGetDrawablePort to get the portPtr. It will * correctly find the container's port. */ macWin->view = nil; macWin->context = NULL; macWin->size = CGSizeZero; macWin->visRgn = NULL; macWin->aboveVisRgn = NULL; macWin->drawRgn = NULL; macWin->referenceCount = 0; macWin->flags = TK_CLIP_INVALID; macWin->toplevel = macWin; macWin->toplevel->referenceCount++; winPtr->flags |= TK_EMBEDDED; /* * Make a copy of the TK_EMBEDDED flag, since sometimes we need this to * get the port after the TkWindow structure has been freed. */ macWin->flags |= TK_EMBEDDED; /* * Now check whether it is embedded in another Tk widget. If not (the * first case below) we see if there is an in-process embedding handler * registered, and if so, let that fill in the rest of the macWin. */ if (containerPtr == NULL) { /* * If someone has registered an in-process embedding handler, then * see if it can handle this window... */ if (tkMacOSXEmbedHandler == NULL || tkMacOSXEmbedHandler->registerWinProc((long) parent, (Tk_Window) winPtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "The window ID %s does not correspond to a valid Tk Window", string)); Tcl_SetErrorCode(interp, "TK", "EMBED", "HANDLE", NULL); return TCL_ERROR; } containerPtr = ckalloc(sizeof(Container)); containerPtr->parentPtr = NULL; containerPtr->embedded = (Window) macWin; containerPtr->embeddedPtr = macWin->winPtr; containerPtr->nextPtr = firstContainerPtr; firstContainerPtr = containerPtr; } else { /* * The window is embedded in another Tk window. */ macWin->xOff = parent->winPtr->privatePtr->xOff + parent->winPtr->changes.border_width + winPtr->changes.x; macWin->yOff = parent->winPtr->privatePtr->yOff + parent->winPtr->changes.border_width + winPtr->changes.y; /* * Finish filling up the container structure with the embedded * window's information. */ containerPtr->embedded = (Window) macWin; containerPtr->embeddedPtr = macWin->winPtr; /* * Create an event handler to clean up the Container structure when * tkwin is eventually deleted. */ Tk_CreateEventHandler(tkwin, StructureNotifyMask, EmbeddedEventProc, winPtr); } return TCL_OK; }
/* ARGSUSED */ static int MemoryCmd( ClientData clientData, Tcl_Interp *interp, int argc, const char *argv[]) { const char *fileName; FILE *fileP; Tcl_DString buffer; int result; size_t len; if (argc < 2) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " option [args..]\"", NULL); return TCL_ERROR; } if ((strcmp(argv[1],"active") == 0) || (strcmp(argv[1],"display") == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " file\"", NULL); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); if (fileName == NULL) { return TCL_ERROR; } result = Tcl_DumpActiveMemory(fileName); Tcl_DStringFree(&buffer); if (result != TCL_OK) { Tcl_AppendResult(interp, "error accessing ", argv[2], NULL); return TCL_ERROR; } return TCL_OK; } if (strcmp(argv[1],"break_on_malloc") == 0) { if (argc != 3) { goto argError; } if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } if (strcmp(argv[1],"info") == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10lu\n%-25s %10d\n%-25s %10lu\n", "total mallocs", total_mallocs, "total frees", total_frees, "current packets allocated", current_malloc_packets, "current bytes allocated", current_bytes_malloced, "maximum packets allocated", maximum_malloc_packets, "maximum bytes allocated", maximum_bytes_malloced)); return TCL_OK; } if (strcmp(argv[1],"init") == 0) { if (argc != 3) { goto bad_suboption; } init_malloced_bodies = (strcmp(argv[2],"on") == 0); return TCL_OK; } if (strcmp(argv[1],"objs") == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " objs file\"", NULL); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); if (fileName == NULL) { return TCL_ERROR; } fileP = fopen(fileName, "w"); if (fileP == NULL) { Tcl_AppendResult(interp, "cannot open output file", NULL); return TCL_ERROR; } TclDbDumpActiveObjects(fileP); fclose(fileP); Tcl_DStringFree(&buffer); return TCL_OK; } if (strcmp(argv[1],"onexit") == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " onexit file\"", NULL); return TCL_ERROR; } fileName = Tcl_TranslateFileName(interp, argv[2], &buffer); if (fileName == NULL) { return TCL_ERROR; } onExitMemDumpFileName = dumpFile; strcpy(onExitMemDumpFileName,fileName); Tcl_DStringFree(&buffer); return TCL_OK; } if (strcmp(argv[1],"tag") == 0) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " tag string\"", NULL); return TCL_ERROR; } if ((curTagPtr != NULL) && (curTagPtr->refCount == 0)) { TclpFree((char *) curTagPtr); } len = strlen(argv[2]); curTagPtr = (MemTag *) TclpAlloc(TAG_SIZE(len)); curTagPtr->refCount = 0; memcpy(curTagPtr->string, argv[2], len + 1); return TCL_OK; } if (strcmp(argv[1],"trace") == 0) { if (argc != 3) { goto bad_suboption; } alloc_tracing = (strcmp(argv[2],"on") == 0); return TCL_OK; } if (strcmp(argv[1],"trace_on_at_malloc") == 0) { if (argc != 3) { goto argError; } if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) { return TCL_ERROR; } return TCL_OK; } if (strcmp(argv[1],"validate") == 0) { if (argc != 3) { goto bad_suboption; } validate_memory = (strcmp(argv[2],"on") == 0); return TCL_OK; } Tcl_AppendResult(interp, "bad option \"", argv[1], "\": should be active, break_on_malloc, info, init, objs, onexit, " "tag, trace, trace_on_at_malloc, or validate", NULL); return TCL_ERROR; argError: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " count\"", NULL); return TCL_ERROR; bad_suboption: Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " ", argv[1], " on|off\"", NULL); return TCL_ERROR; }
static int TestwineventObjCmd( ClientData clientData, /* Main window for application. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument strings. */ { HWND hwnd = 0; HWND child = 0; HWND control; int id; char *rest; UINT message; WPARAM wParam; LPARAM lParam; LRESULT result; static const TkStateMap messageMap[] = { {WM_LBUTTONDOWN, "WM_LBUTTONDOWN"}, {WM_LBUTTONUP, "WM_LBUTTONUP"}, {WM_CHAR, "WM_CHAR"}, {WM_GETTEXT, "WM_GETTEXT"}, {WM_SETTEXT, "WM_SETTEXT"}, {WM_COMMAND, "WM_COMMAND"}, {-1, NULL} }; if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]), "debug") == 0)) { int b; if (Tcl_GetBoolean(interp, Tcl_GetString(objv[2]), &b) != TCL_OK) { return TCL_ERROR; } TkWinDialogDebug(b); return TCL_OK; } if (objc < 4) { return TCL_ERROR; } hwnd = INT2PTR(strtol(Tcl_GetString(objv[1]), &rest, 0)); if (rest == Tcl_GetString(objv[1])) { hwnd = FindWindowA(NULL, Tcl_GetString(objv[1])); if (hwnd == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("no such window", -1)); return TCL_ERROR; } } UpdateWindow(hwnd); id = strtol(Tcl_GetString(objv[2]), &rest, 0); if (rest == Tcl_GetString(objv[2])) { char buf[256]; child = GetWindow(hwnd, GW_CHILD); while (child != NULL) { SendMessageA(child, WM_GETTEXT, (WPARAM) sizeof(buf), (LPARAM) buf); if (strcasecmp(buf, Tcl_GetString(objv[2])) == 0) { id = GetDlgCtrlID(child); break; } child = GetWindow(child, GW_HWNDNEXT); } if (child == NULL) { Tcl_AppendResult(interp, "could not find a control matching \"", Tcl_GetString(objv[2]), "\"", NULL); return TCL_ERROR; } } message = TkFindStateNum(NULL, NULL, messageMap, Tcl_GetString(objv[3])); wParam = 0; lParam = 0; if (objc > 4) { wParam = strtol(Tcl_GetString(objv[4]), NULL, 0); } if (objc > 5) { lParam = strtol(Tcl_GetString(objv[5]), NULL, 0); } switch (message) { case WM_GETTEXT: { Tcl_DString ds; char buf[256]; #if 0 GetDlgItemTextA(hwnd, id, buf, 256); #else control = TestFindControl(hwnd, id); if (control == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("Could not find control with id %d", id)); return TCL_ERROR; } buf[0] = 0; SendMessageA(control, WM_GETTEXT, (WPARAM)sizeof(buf), (LPARAM) buf); #endif Tcl_ExternalToUtfDString(NULL, buf, -1, &ds); Tcl_AppendResult(interp, Tcl_DStringValue(&ds), NULL); Tcl_DStringFree(&ds); break; } case WM_SETTEXT: { Tcl_DString ds; control = TestFindControl(hwnd, id); if (control == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("Could not find control with id %d", id)); return TCL_ERROR; } Tcl_UtfToExternalDString(NULL, Tcl_GetString(objv[4]), -1, &ds); result = SendMessageA(control, WM_SETTEXT, 0, (LPARAM) Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); if (result == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj("failed to send text to dialog: ", -1)); AppendSystemError(interp, GetLastError()); return TCL_ERROR; } break; } case WM_COMMAND: { char buf[TCL_INTEGER_SPACE]; if (objc < 5) { wParam = MAKEWPARAM(id, 0); lParam = (LPARAM)child; } sprintf(buf, "%d", (int) SendMessageA(hwnd, message, wParam, lParam)); Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1)); break; } default: { char buf[TCL_INTEGER_SPACE]; sprintf(buf, "%d", (int) SendDlgItemMessageA(hwnd, id, message, wParam, lParam)); Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1)); break; } } return TCL_OK; }
int TkpUseWindow( Tcl_Interp *interp, /* If not NULL, used for error reporting if * string is bogus. */ Tk_Window tkwin, /* Tk window that does not yet have an * associated X window. */ const char *string) /* String identifying an X window to use for * tkwin; must be an integer value. */ { TkWindow *winPtr = (TkWindow *) tkwin; TkWindow *usePtr; int id, anyError; Window parent; Tk_ErrorHandler handler; Container *containerPtr; XWindowAttributes parentAtts; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); if (winPtr->window != None) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't modify container after widget is created", -1)); Tcl_SetErrorCode(interp, "TK", "EMBED", "POST_CREATE", NULL); return TCL_ERROR; } if (Tcl_GetInt(interp, string, &id) != TCL_OK) { return TCL_ERROR; } parent = (Window) id; usePtr = (TkWindow *) Tk_IdToWindow(winPtr->display, parent); if (usePtr != NULL && !(usePtr->flags & TK_CONTAINER)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "window \"%s\" doesn't have -container option set", usePtr->pathName)); Tcl_SetErrorCode(interp, "TK", "EMBED", "CONTAINER", NULL); return TCL_ERROR; } /* * Tk sets the window colormap to the screen default colormap in * tkWindow.c:AllocWindow. This doesn't work well for embedded windows. So * we override the colormap and visual settings to be the same as the * parent window (which is in the container app). */ anyError = 0; handler = Tk_CreateErrorHandler(winPtr->display, -1, -1, -1, EmbedErrorProc, &anyError); if (!XGetWindowAttributes(winPtr->display, parent, &parentAtts)) { anyError = 1; } XSync(winPtr->display, False); Tk_DeleteErrorHandler(handler); if (anyError) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't create child of window \"%s\"", string)); Tcl_SetErrorCode(interp, "TK", "EMBED", "NO_TARGET", NULL); } return TCL_ERROR; } Tk_SetWindowVisual(tkwin, parentAtts.visual, parentAtts.depth, parentAtts.colormap); /* * Create an event handler to clean up the Container structure when tkwin * is eventually deleted. */ Tk_CreateEventHandler(tkwin, StructureNotifyMask, EmbeddedEventProc, winPtr); /* * Save information about the container and the embedded window in a * Container structure. If there is already an existing Container * structure, it means that both container and embedded app. are in the * same process. */ for (containerPtr = tsdPtr->firstContainerPtr; containerPtr != NULL; containerPtr = containerPtr->nextPtr) { if (containerPtr->parent == parent) { winPtr->flags |= TK_BOTH_HALVES; containerPtr->parentPtr->flags |= TK_BOTH_HALVES; break; } } if (containerPtr == NULL) { containerPtr = ckalloc(sizeof(Container)); containerPtr->parent = parent; containerPtr->parentRoot = parentAtts.root; containerPtr->parentPtr = NULL; containerPtr->wrapper = None; containerPtr->nextPtr = tsdPtr->firstContainerPtr; tsdPtr->firstContainerPtr = containerPtr; } containerPtr->embeddedPtr = winPtr; winPtr->flags |= TK_EMBEDDED; return TCL_OK; }
int Tk_Grab( Tcl_Interp *interp, /* Used for error reporting. */ Tk_Window tkwin, /* Window on whose behalf the pointer is to be * grabbed. */ int grabGlobal) /* Non-zero means issue a grab to the server * so that no other application gets mouse or * keyboard events. Zero means the grab only * applies within this application. */ { int grabResult, numTries; TkWindow *winPtr = (TkWindow *) tkwin; TkDisplay *dispPtr = winPtr->dispPtr; TkWindow *winPtr2; unsigned int serial; ReleaseButtonGrab(dispPtr); if (dispPtr->eventualGrabWinPtr != NULL) { if ((dispPtr->eventualGrabWinPtr == winPtr) && (grabGlobal == ((dispPtr->grabFlags & GRAB_GLOBAL) != 0))) { return TCL_OK; } if (dispPtr->eventualGrabWinPtr->mainPtr != winPtr->mainPtr) { goto alreadyGrabbed; } Tk_Ungrab((Tk_Window) dispPtr->eventualGrabWinPtr); } Tk_MakeWindowExist(tkwin); if (!grabGlobal) { Window dummy1, dummy2; int dummy3, dummy4, dummy5, dummy6; unsigned int state; /* * Local grab. However, if any mouse buttons are down, turn it into a * global grab temporarily, until the last button goes up. This does * two things: (a) it makes sure that we see the button-up event; and * (b) it allows us to track mouse motion among all of the windows of * this application. */ dispPtr->grabFlags &= ~(GRAB_GLOBAL|GRAB_TEMP_GLOBAL); XQueryPointer(dispPtr->display, winPtr->window, &dummy1, &dummy2, &dummy3, &dummy4, &dummy5, &dummy6, &state); if (state & ALL_BUTTONS) { dispPtr->grabFlags |= GRAB_TEMP_GLOBAL; goto setGlobalGrab; } } else { dispPtr->grabFlags |= GRAB_GLOBAL; setGlobalGrab: /* * Tricky point: must ungrab before grabbing. This is needed in case * there is a button auto-grab already in effect. If there is, and the * mouse has moved to a different window, X won't generate enter and * leave events to move the mouse if we grab without ungrabbing. */ XUngrabPointer(dispPtr->display, CurrentTime); serial = NextRequest(dispPtr->display); /* * Another tricky point: there are races with some window managers * that can cause grabs to fail because the window manager hasn't * released its grab quickly enough. To work around this problem, * retry a few times after AlreadyGrabbed errors to give the grab * release enough time to register with the server. */ grabResult = 0; /* Needed only to prevent gcc compiler * warnings. */ for (numTries = 0; numTries < 10; numTries++) { grabResult = XGrabPointer(dispPtr->display, winPtr->window, True, ButtonPressMask|ButtonReleaseMask|ButtonMotionMask |PointerMotionMask, GrabModeAsync, GrabModeAsync, None, None, CurrentTime); if (grabResult != AlreadyGrabbed) { break; } Tcl_Sleep(100); } if (grabResult != 0) { goto grabError; } grabResult = XGrabKeyboard(dispPtr->display, Tk_WindowId(tkwin), False, GrabModeAsync, GrabModeAsync, CurrentTime); if (grabResult != 0) { XUngrabPointer(dispPtr->display, CurrentTime); goto grabError; } /* * Eat up any grab-related events generated by the server for the * grab. There are several reasons for doing this: * * 1. We have to synthesize the events for local grabs anyway, since * the server doesn't participate in them. * 2. The server doesn't always generate the right events for global * grabs (e.g. it generates events even if the current window is in * the grab tree, which we don't want). * 3. We want all the grab-related events to be processed immediately * (before other events that are already queued); events coming * from the server will be in the wrong place, but events we * synthesize here will go to the front of the queue. */ EatGrabEvents(dispPtr, serial); } /* * Synthesize leave events to move the pointer from its current window up * to the lowest ancestor that it has in common with the grab window. * However, only do this if the pointer is outside the grab window's * subtree but inside the grab window's application. */ if ((dispPtr->serverWinPtr != NULL) && (dispPtr->serverWinPtr->mainPtr == winPtr->mainPtr)) { for (winPtr2 = dispPtr->serverWinPtr; ; winPtr2 = winPtr2->parentPtr) { if (winPtr2 == winPtr) { break; } if (winPtr2 == NULL) { MovePointer2(dispPtr->serverWinPtr, winPtr, NotifyGrab, 1, 0); break; } } } QueueGrabWindowChange(dispPtr, winPtr); return TCL_OK; grabError: if (grabResult == GrabNotViewable) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "grab failed: window not viewable", -1)); Tcl_SetErrorCode(interp, "TK", "GRAB", "UNVIEWABLE", NULL); } else if (grabResult == AlreadyGrabbed) { alreadyGrabbed: Tcl_SetObjResult(interp, Tcl_NewStringObj( "grab failed: another application has grab", -1)); Tcl_SetErrorCode(interp, "TK", "GRAB", "GRABBED", NULL); } else if (grabResult == GrabFrozen) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "grab failed: keyboard or pointer frozen", -1)); Tcl_SetErrorCode(interp, "TK", "GRAB", "FROZEN", NULL); } else if (grabResult == GrabInvalidTime) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "grab failed: invalid time", -1)); Tcl_SetErrorCode(interp, "TK", "GRAB", "BAD_TIME", NULL); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "grab failed for unknown reason (code %d)", grabResult)); Tcl_SetErrorCode(interp, "TK", "GRAB", "UNKNOWN", NULL); } return TCL_ERROR; }
int Tk_ParseArgv( Tcl_Interp *interp, /* Place to store error message. */ Tk_Window tkwin, /* Window to use for setting Tk options. NULL * means ignore Tk option specs. */ int *argcPtr, /* Number of arguments in argv. Modified to * hold # args left in argv at end. */ const char **argv, /* Array of arguments. Modified to hold those * that couldn't be processed here. */ const Tk_ArgvInfo *argTable, /* Array of option descriptions */ int flags) /* Or'ed combination of various flag bits, * such as TK_ARGV_NO_DEFAULTS. */ { register const Tk_ArgvInfo *infoPtr; /* Pointer to the current entry in the table * of argument descriptions. */ const Tk_ArgvInfo *matchPtr;/* Descriptor that matches current argument. */ const char *curArg; /* Current argument */ register char c; /* Second character of current arg (used for * quick check for matching; use 2nd char. * because first char. will almost always be * '-'). */ int srcIndex; /* Location from which to read next argument * from argv. */ int dstIndex; /* Index into argv to which next unused * argument should be copied (never greater * than srcIndex). */ int argc; /* # arguments in argv still to process. */ size_t length; /* Number of characters in current argument. */ char *endPtr; /* Used for identifying junk in arguments. */ int i; if (flags & TK_ARGV_DONT_SKIP_FIRST_ARG) { srcIndex = dstIndex = 0; argc = *argcPtr; } else { srcIndex = dstIndex = 1; argc = *argcPtr-1; } while (argc > 0) { curArg = argv[srcIndex]; srcIndex++; argc--; length = strlen(curArg); if (length > 0) { c = curArg[1]; } else { c = 0; } /* * Loop throught the argument descriptors searching for one with the * matching key string. If found, leave a pointer to it in matchPtr. */ matchPtr = NULL; for (i = 0; i < 2; i++) { if (i == 0) { infoPtr = argTable; } else { infoPtr = defaultTable; } for (; (infoPtr != NULL) && (infoPtr->type != TK_ARGV_END); infoPtr++) { if (infoPtr->key == NULL) { continue; } if ((infoPtr->key[1] != c) || (strncmp(infoPtr->key, curArg, length) != 0)) { continue; } if ((tkwin == NULL) && ((infoPtr->type == TK_ARGV_CONST_OPTION) || (infoPtr->type == TK_ARGV_OPTION_VALUE) || (infoPtr->type == TK_ARGV_OPTION_NAME_VALUE))) { continue; } if (infoPtr->key[length] == 0) { matchPtr = infoPtr; goto gotMatch; } if (flags & TK_ARGV_NO_ABBREV) { continue; } if (matchPtr != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "ambiguous option \"%s\"", curArg)); Tcl_SetErrorCode(interp, "TK", "ARG", "AMBIGUOUS", curArg, NULL); return TCL_ERROR; } matchPtr = infoPtr; } } if (matchPtr == NULL) { /* * Unrecognized argument. Just copy it down, unless the caller * prefers an error to be registered. */ if (flags & TK_ARGV_NO_LEFTOVERS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unrecognized argument \"%s\"", curArg)); Tcl_SetErrorCode(interp, "TK", "ARG", "UNRECOGNIZED", curArg, NULL); return TCL_ERROR; } argv[dstIndex] = curArg; dstIndex++; continue; } /* * Take the appropriate action based on the option type */ gotMatch: infoPtr = matchPtr; switch (infoPtr->type) { case TK_ARGV_CONSTANT: *((int *) infoPtr->dst) = PTR2INT(infoPtr->src); break; case TK_ARGV_INT: if (argc == 0) { goto missingArg; } *((int *) infoPtr->dst) = strtol(argv[srcIndex], &endPtr, 0); if ((endPtr == argv[srcIndex]) || (*endPtr != 0)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected %s argument for \"%s\" but got \"%s\"", "integer", infoPtr->key, argv[srcIndex])); Tcl_SetErrorCode(interp, "TK", "ARG", "INTEGER", curArg,NULL); return TCL_ERROR; } srcIndex++; argc--; break; case TK_ARGV_STRING: if (argc == 0) { goto missingArg; } *((const char **) infoPtr->dst) = argv[srcIndex]; srcIndex++; argc--; break; case TK_ARGV_UID: if (argc == 0) { goto missingArg; } *((Tk_Uid *) infoPtr->dst) = Tk_GetUid(argv[srcIndex]); srcIndex++; argc--; break; case TK_ARGV_REST: *((int *) infoPtr->dst) = dstIndex; goto argsDone; case TK_ARGV_FLOAT: if (argc == 0) { goto missingArg; } *((double *) infoPtr->dst) = strtod(argv[srcIndex], &endPtr); if ((endPtr == argv[srcIndex]) || (*endPtr != 0)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected %s argument for \"%s\" but got \"%s\"", "floating-point", infoPtr->key, argv[srcIndex])); Tcl_SetErrorCode(interp, "TK", "ARG", "FLOAT", curArg, NULL); return TCL_ERROR; } srcIndex++; argc--; break; case TK_ARGV_FUNC: { typedef int (ArgvFunc)(char *, const char *, const char *); ArgvFunc *handlerProc = (ArgvFunc *) infoPtr->src; if (handlerProc(infoPtr->dst, infoPtr->key, argv[srcIndex])) { srcIndex++; argc--; } break; } case TK_ARGV_GENFUNC: { typedef int (ArgvGenFunc)(char *, Tcl_Interp *, const char *, int, const char **); ArgvGenFunc *handlerProc = (ArgvGenFunc *) infoPtr->src; argc = handlerProc(infoPtr->dst, interp, infoPtr->key, argc, argv+srcIndex); if (argc < 0) { return TCL_ERROR; } break; } case TK_ARGV_HELP: PrintUsage(interp, argTable, flags); Tcl_SetErrorCode(interp, "TK", "ARG", "HELP", NULL); return TCL_ERROR; case TK_ARGV_CONST_OPTION: Tk_AddOption(tkwin, infoPtr->dst, infoPtr->src, TK_INTERACTIVE_PRIO); break; case TK_ARGV_OPTION_VALUE: if (argc < 1) { goto missingArg; } Tk_AddOption(tkwin, infoPtr->dst, argv[srcIndex], TK_INTERACTIVE_PRIO); srcIndex++; argc--; break; case TK_ARGV_OPTION_NAME_VALUE: if (argc < 2) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" option requires two following arguments", curArg)); Tcl_SetErrorCode(interp, "TK", "ARG", "NAME_VALUE", curArg, NULL); return TCL_ERROR; } Tk_AddOption(tkwin, argv[srcIndex], argv[srcIndex+1], TK_INTERACTIVE_PRIO); srcIndex += 2; argc -= 2; break; default: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument type %d in Tk_ArgvInfo", infoPtr->type)); Tcl_SetErrorCode(interp, "TK", "API_ABUSE", NULL); return TCL_ERROR; } } /* * If we broke out of the loop because of an OPT_REST argument, copy the * remaining arguments down. */ argsDone: while (argc) { argv[dstIndex] = argv[srcIndex]; srcIndex++; dstIndex++; argc--; } argv[dstIndex] = NULL; *argcPtr = dstIndex; return TCL_OK; missingArg: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" option requires an additional argument", curArg)); Tcl_SetErrorCode(interp, "TK", "ARG", "MISSING", curArg, NULL); return TCL_ERROR; }
void Tcl_Main( int argc, /* Number of arguments. */ char **argv, /* Array of argument strings. */ Tcl_AppInitProc *appInitProc) /* Application-specific initialization * function to call after most initialization * but before starting to execute commands. */ { Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL; const char *encodingName = NULL; PromptType prompt = PROMPT_START; int code, length, tty, exitCode = 0; Tcl_Channel inChannel, outChannel, errChannel; Tcl_Interp *interp; Tcl_DString appName; Tcl_FindExecutable(argv[0]); interp = Tcl_CreateInterp(); Tcl_InitMemory(interp); /* * If the application has not already set a startup script, parse the * first few command line arguments to determine the script path and * encoding. */ if (NULL == Tcl_GetStartupScript(NULL)) { /* * Check whether first 3 args (argv[1] - argv[3]) look like * -encoding ENCODING FILENAME * or like * FILENAME */ if ((argc > 3) && (0 == strcmp("-encoding", argv[1])) && ('-' != argv[3][0])) { Tcl_SetStartupScript(Tcl_NewStringObj(argv[3], -1), argv[2]); argc -= 3; argv += 3; } else if ((argc > 1) && ('-' != argv[1][0])) { Tcl_SetStartupScript(Tcl_NewStringObj(argv[1], -1), NULL); argc--; argv++; } } path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { Tcl_ExternalToUtfDString(NULL, argv[0], -1, &appName); } else { const char *pathName = Tcl_GetStringFromObj(path, &length); Tcl_ExternalToUtfDString(NULL, pathName, length, &appName); path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1); Tcl_SetStartupScript(path, encodingName); } Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY); Tcl_DStringFree(&appName); argc--; argv++; Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY); argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { Tcl_DString ds; Tcl_ExternalToUtfDString(NULL, *argv++, -1, &ds); Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj( Tcl_DStringValue(&ds), Tcl_DStringLength(&ds))); Tcl_DStringFree(&ds); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); /* * Set the "tcl_interactive" variable. */ tty = isatty(0); Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0", TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. */ Tcl_Preserve(interp); if (appInitProc(interp) != TCL_OK) { errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel) { Tcl_WriteChars(errChannel, "application-specific initialization failed: ", -1); Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); Tcl_WriteChars(errChannel, "\n", 1); } } if (Tcl_InterpDeleted(interp)) { goto done; } if (Tcl_LimitExceeded(interp)) { goto done; } /* * If a script file was specified then just source that file and quit. * Must fetch it again, as the appInitProc might have reset it. */ path = Tcl_GetStartupScript(&encodingName); if (path != NULL) { code = Tcl_FSEvalFileEx(interp, path, encodingName); if (code != TCL_OK) { errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); Tcl_Obj *keyPtr, *valuePtr; TclNewLiteralStringObj(keyPtr, "-errorinfo"); Tcl_IncrRefCount(keyPtr); Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); if (valuePtr) { Tcl_WriteObj(errChannel, valuePtr); } Tcl_WriteChars(errChannel, "\n", 1); } exitCode = 1; } goto done; } /* * We're running interactively. Source a user-specific startup file if the * application specified one and if the file exists. */ Tcl_SourceRCFile(interp); if (Tcl_LimitExceeded(interp)) { goto done; } /* * Process commands from stdin until there's an end-of-file. Note that we * need to fetch the standard channels again after every eval, since they * may have been changed. */ commandPtr = Tcl_NewObj(); Tcl_IncrRefCount(commandPtr); /* * Get a new value for tty if anyone writes to ::tcl_interactive */ Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN); inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); while ((inChannel != NULL) && !Tcl_InterpDeleted(interp)) { if (mainLoopProc == NULL) { if (tty) { Prompt(interp, &prompt); if (Tcl_InterpDeleted(interp)) { break; } if (Tcl_LimitExceeded(interp)) { break; } inChannel = Tcl_GetStdChannel(TCL_STDIN); if (inChannel == NULL) { break; } } if (Tcl_IsShared(commandPtr)) { Tcl_DecrRefCount(commandPtr); commandPtr = Tcl_DuplicateObj(commandPtr); Tcl_IncrRefCount(commandPtr); } length = Tcl_GetsObj(inChannel, commandPtr); if (length < 0) { if (Tcl_InputBlocked(inChannel)) { /* * This can only happen if stdin has been set to * non-blocking. In that case cycle back and try again. * This sets up a tight polling loop (since we have no * event loop running). If this causes bad CPU hogging, we * might try toggling the blocking on stdin instead. */ continue; } /* * Either EOF, or an error on stdin; we're done */ break; } /* * Add the newline removed by Tcl_GetsObj back to the string. Have * to add it back before testing completeness, because it can make * a difference. [Bug 1775878] */ if (Tcl_IsShared(commandPtr)) { Tcl_DecrRefCount(commandPtr); commandPtr = Tcl_DuplicateObj(commandPtr); Tcl_IncrRefCount(commandPtr); } Tcl_AppendToObj(commandPtr, "\n", 1); if (!TclObjCommandComplete(commandPtr)) { prompt = PROMPT_CONTINUE; continue; } prompt = PROMPT_START; /* * The final newline is syntactically redundant, and causes some * error messages troubles deeper in, so lop it back off. */ Tcl_GetStringFromObj(commandPtr, &length); Tcl_SetObjLength(commandPtr, --length); code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL); inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); errChannel = Tcl_GetStdChannel(TCL_STDERR); Tcl_DecrRefCount(commandPtr); commandPtr = Tcl_NewObj(); Tcl_IncrRefCount(commandPtr); if (code != TCL_OK) { if (errChannel) { Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); Tcl_WriteChars(errChannel, "\n", 1); } } else if (tty) { resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); Tcl_GetStringFromObj(resultPtr, &length); if ((length > 0) && outChannel) { Tcl_WriteObj(outChannel, resultPtr); Tcl_WriteChars(outChannel, "\n", 1); } Tcl_DecrRefCount(resultPtr); } } else { /* (mainLoopProc != NULL) */ /* * If a main loop has been defined while running interactively, we * want to start a fileevent based prompt by establishing a * channel handler for stdin. */ InteractiveState *isPtr = NULL; if (inChannel) { if (tty) { Prompt(interp, &prompt); } isPtr = (InteractiveState *) ckalloc(sizeof(InteractiveState)); isPtr->input = inChannel; isPtr->tty = tty; isPtr->commandPtr = commandPtr; isPtr->prompt = prompt; isPtr->interp = interp; Tcl_UnlinkVar(interp, "tcl_interactive"); Tcl_LinkVar(interp, "tcl_interactive", (char *) &(isPtr->tty), TCL_LINK_BOOLEAN); Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc, isPtr); } mainLoopProc(); mainLoopProc = NULL; if (inChannel) { tty = isPtr->tty; Tcl_UnlinkVar(interp, "tcl_interactive"); Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN); prompt = isPtr->prompt; commandPtr = isPtr->commandPtr; if (isPtr->input != NULL) { Tcl_DeleteChannelHandler(isPtr->input, StdinProc, isPtr); } ckfree((char *) isPtr); } inChannel = Tcl_GetStdChannel(TCL_STDIN); outChannel = Tcl_GetStdChannel(TCL_STDOUT); errChannel = Tcl_GetStdChannel(TCL_STDERR); } #ifdef TCL_MEM_DEBUG /* * This code here only for the (unsupported and deprecated) [checkmem] * command. */ if (tclMemDumpFileName != NULL) { mainLoopProc = NULL; Tcl_DeleteInterp(interp); } #endif } done: if ((exitCode == 0) && (mainLoopProc != NULL) && !Tcl_LimitExceeded(interp)) { /* * If everything has gone OK so far, call the main loop proc, if it * exists. Packages (like Tk) can set it to start processing events at * this point. */ mainLoopProc(); mainLoopProc = NULL; } if (commandPtr != NULL) { Tcl_DecrRefCount(commandPtr); } /* * Rather than calling exit, invoke the "exit" command so that users can * replace "exit" with some other command to do additional cleanup on * exit. The Tcl_EvalObjEx call should never return. */ if (!Tcl_InterpDeleted(interp)) { if (!Tcl_LimitExceeded(interp)) { Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); Tcl_IncrRefCount(cmd); Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(cmd); } /* * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual * is happening. Maybe interp has been deleted; maybe [exit] was * redefined, maybe we've blown up because of an exceeded limit. We * still want to cleanup and exit. */ if (!Tcl_InterpDeleted(interp)) { Tcl_DeleteInterp(interp); } } Tcl_SetStartupScript(NULL, NULL); /* * If we get here, the master interp has been deleted. Allow its * destruction with the last matching Tcl_Release. */ Tcl_Release(interp); Tcl_Exit(exitCode); }
static int RectOvalToPostscript( Tcl_Interp *interp, /* Interpreter for error reporting. */ Tk_Canvas canvas, /* Information about overall canvas. */ Tk_Item *itemPtr, /* Item for which Postscript is wanted. */ int prepass) /* 1 means this is a prepass to collect font * information; 0 means final Postscript is * being created. */ { Tcl_Obj *pathObj, *psObj; RectOvalItem *rectOvalPtr = (RectOvalItem *) itemPtr; double y1, y2; XColor *color; XColor *fillColor; Pixmap fillStipple; Tk_State state = itemPtr->state; Tcl_InterpState interpState; y1 = Tk_CanvasPsY(canvas, rectOvalPtr->bbox[1]); y2 = Tk_CanvasPsY(canvas, rectOvalPtr->bbox[3]); /* * Generate a string that creates a path for the rectangle or oval. This * is the only part of the function's code that is type-specific. */ if (rectOvalPtr->header.typePtr == &tkRectangleType) { pathObj = Tcl_ObjPrintf( "%.15g %.15g moveto " "%.15g 0 rlineto " "0 %.15g rlineto " "%.15g 0 rlineto " "closepath\n", rectOvalPtr->bbox[0], y1, rectOvalPtr->bbox[2]-rectOvalPtr->bbox[0], y2-y1, rectOvalPtr->bbox[0]-rectOvalPtr->bbox[2]); } else { pathObj = Tcl_ObjPrintf( "matrix currentmatrix\n" "%.15g %.15g translate " "%.15g %.15g scale " "1 0 moveto 0 0 1 0 360 arc\n" "setmatrix\n", (rectOvalPtr->bbox[0] + rectOvalPtr->bbox[2])/2, (y1 + y2)/2, (rectOvalPtr->bbox[2] - rectOvalPtr->bbox[0])/2, (y1 - y2)/2); } if (state == TK_STATE_NULL) { state = Canvas(canvas)->canvas_state; } color = rectOvalPtr->outline.color; fillColor = rectOvalPtr->fillColor; fillStipple = rectOvalPtr->fillStipple; if (Canvas(canvas)->currentItemPtr == itemPtr) { if (rectOvalPtr->outline.activeColor!=NULL) { color = rectOvalPtr->outline.activeColor; } if (rectOvalPtr->activeFillColor!=NULL) { fillColor = rectOvalPtr->activeFillColor; } if (rectOvalPtr->activeFillStipple!=None) { fillStipple = rectOvalPtr->activeFillStipple; } } else if (state == TK_STATE_DISABLED) { if (rectOvalPtr->outline.disabledColor!=NULL) { color = rectOvalPtr->outline.disabledColor; } if (rectOvalPtr->disabledFillColor!=NULL) { fillColor = rectOvalPtr->disabledFillColor; } if (rectOvalPtr->disabledFillStipple!=None) { fillStipple = rectOvalPtr->disabledFillStipple; } } /* * Make our working space. */ psObj = Tcl_NewObj(); interpState = Tcl_SaveInterpState(interp, TCL_OK); /* * First draw the filled area of the rectangle. */ if (fillColor != NULL) { Tcl_AppendObjToObj(psObj, pathObj); Tcl_ResetResult(interp); if (Tk_CanvasPsColor(interp, canvas, fillColor) != TCL_OK) { goto error; } Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp)); if (fillStipple != None) { Tcl_AppendToObj(psObj, "clip ", -1); Tcl_ResetResult(interp); if (Tk_CanvasPsStipple(interp, canvas, fillStipple) != TCL_OK) { goto error; } Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp)); if (color != NULL) { Tcl_AppendToObj(psObj, "grestore gsave\n", -1); } } else { Tcl_AppendToObj(psObj, "fill\n", -1); } } /* * Now draw the outline, if there is one. */ if (color != NULL) { Tcl_AppendObjToObj(psObj, pathObj); Tcl_AppendToObj(psObj, "0 setlinejoin 2 setlinecap\n", -1); Tcl_ResetResult(interp); if (Tk_CanvasPsOutline(canvas, itemPtr, &rectOvalPtr->outline)!= TCL_OK) { goto error; } Tcl_AppendObjToObj(psObj, Tcl_GetObjResult(interp)); } /* * Plug the accumulated postscript back into the result. */ (void) Tcl_RestoreInterpState(interp, interpState); Tcl_AppendObjToObj(Tcl_GetObjResult(interp), psObj); Tcl_DecrRefCount(psObj); Tcl_DecrRefCount(pathObj); return TCL_OK; error: Tcl_DiscardInterpState(interpState); Tcl_DecrRefCount(psObj); Tcl_DecrRefCount(pathObj); return TCL_ERROR; }
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; }
int TclpDlopen( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Obj *pathPtr, /* Name of the file containing the desired * code (UTF-8). */ Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded * file which will be passed back to * (*unloadProcPtr)() to unload the file. */ Tcl_FSUnloadFileProc **unloadProcPtr, /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this * file. */ int flags) { void *handle; Tcl_LoadHandle newHandle; const char *native; int dlopenflags = 0; /* * First try the full path the user gave us. This is particularly * important if the cwd is inside a vfs, and we are trying to load using a * relative path. */ native = Tcl_FSGetNativePath(pathPtr); /* * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070] */ if (flags & TCL_LOAD_GLOBAL) { dlopenflags |= RTLD_GLOBAL; } else { dlopenflags |= RTLD_LOCAL; } if (flags & TCL_LOAD_LAZY) { dlopenflags |= RTLD_LAZY; } else { dlopenflags |= RTLD_NOW; } handle = dlopen(native, dlopenflags); if (handle == NULL) { /* * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path. */ Tcl_DString ds; const char *fileName = Tcl_GetString(pathPtr); native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds); /* * Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070] */ handle = dlopen(native, dlopenflags); Tcl_DStringFree(&ds); } if (handle == NULL) { /* * Write the string to a variable first to work around a compiler bug * in the Sun Forte 6 compiler. [Bug 1503729] */ const char *errorStr = dlerror(); if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't load file \"%s\": %s", Tcl_GetString(pathPtr), errorStr)); } return TCL_ERROR; } newHandle = Tcl_Alloc(sizeof(*newHandle)); newHandle->clientData = handle; newHandle->findSymbolProcPtr = &FindSymbol; newHandle->unloadFileProcPtr = &UnloadFile; *unloadProcPtr = &UnloadFile; *loadHandle = newHandle; return TCL_OK; }
int Tk_GetSelection( Tcl_Interp *interp, /* Interpreter to use for reporting errors. */ Tk_Window tkwin, /* Window on whose behalf to retrieve the * selection (determines display from which to * retrieve). */ Atom selection, /* Selection to retrieve. */ Atom target, /* Desired form in which selection is to be * returned. */ Tk_GetSelProc *proc, /* Function to call to process the selection, * once it has been retrieved. */ ClientData clientData) /* Arbitrary value to pass to proc. */ { TkWindow *winPtr = (TkWindow *) tkwin; TkDisplay *dispPtr = winPtr->dispPtr; TkSelectionInfo *infoPtr; ThreadSpecificData *tsdPtr = Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData)); if (dispPtr->multipleAtom == None) { TkSelInit(tkwin); } /* * If the selection is owned by a window managed by this process, then * call the retrieval function directly, rather than going through the X * server (it's dangerous to go through the X server in this case because * it could result in deadlock if an INCR-style selection results). */ for (infoPtr = dispPtr->selectionInfoPtr; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->selection == selection) { break; } } if (infoPtr != NULL) { register TkSelHandler *selPtr; int offset, result, count; char buffer[TK_SEL_BYTES_AT_ONCE+1]; TkSelInProgress ip; for (selPtr = ((TkWindow *) infoPtr->owner)->selHandlerList; selPtr != NULL; selPtr = selPtr->nextPtr) { if (selPtr->target==target && selPtr->selection==selection) { break; } } if (selPtr == NULL) { Atom type; count = TkSelDefaultSelection(infoPtr, target, buffer, TK_SEL_BYTES_AT_ONCE, &type); if (count > TK_SEL_BYTES_AT_ONCE) { Tcl_Panic("selection handler returned too many bytes"); } if (count < 0) { goto cantget; } buffer[count] = 0; result = proc(clientData, interp, buffer); } else { offset = 0; result = TCL_OK; ip.selPtr = selPtr; ip.nextPtr = tsdPtr->pendingPtr; tsdPtr->pendingPtr = &ip; while (1) { count = selPtr->proc(selPtr->clientData, offset, buffer, TK_SEL_BYTES_AT_ONCE); if ((count < 0) || (ip.selPtr == NULL)) { tsdPtr->pendingPtr = ip.nextPtr; goto cantget; } if (count > TK_SEL_BYTES_AT_ONCE) { Tcl_Panic("selection handler returned too many bytes"); } buffer[count] = '\0'; result = proc(clientData, interp, buffer); if ((result != TCL_OK) || (count < TK_SEL_BYTES_AT_ONCE) || (ip.selPtr == NULL)) { break; } offset += count; } tsdPtr->pendingPtr = ip.nextPtr; } return result; } /* * The selection is owned by some other process. */ return TkSelGetSelection(interp, tkwin, selection, target, proc, clientData); cantget: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s selection doesn't exist or form \"%s\" not defined", Tk_GetAtomName(tkwin, selection), Tk_GetAtomName(tkwin, target))); return TCL_ERROR; }
/* ARGSUSED */ int TclpCreateProcess( Tcl_Interp *interp, /* Interpreter in which to leave errors that * occurred when creating the child process. * Error messages from the child process * itself are sent to errorFile. */ int argc, /* Number of arguments in following array. */ const char **argv, /* Array of argument strings in UTF-8. * argv[0] contains the name of the executable * translated using Tcl_TranslateFileName * call). Additional arguments have not been * converted. */ TclFile inputFile, /* If non-NULL, gives the file to use as input * for the child process. If inputFile file is * not readable or is NULL, the child will * receive no standard input. */ TclFile outputFile, /* If non-NULL, gives the file that receives * output from the child process. If * outputFile file is not writeable or is * NULL, output from the child will be * discarded. */ TclFile errorFile, /* If non-NULL, gives the file that receives * errors from the child process. If errorFile * file is not writeable or is NULL, errors * from the child will be discarded. errorFile * may be the same as outputFile. */ Tcl_Pid *pidPtr) /* If this function is successful, pidPtr is * filled with the process id of the child * process. */ { TclFile errPipeIn, errPipeOut; int count, status, fd; char errSpace[200 + TCL_INTEGER_SPACE]; Tcl_DString *dsArray; char **newArgv; int pid, i; errPipeIn = NULL; errPipeOut = NULL; pid = -1; /* * Create a pipe that the child can use to return error information if * anything goes wrong. */ if (TclpCreatePipe(&errPipeIn, &errPipeOut) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't create pipe: %s", Tcl_PosixError(interp))); goto error; } /* * We need to allocate and convert this before the fork so it is properly * deallocated later */ dsArray = TclStackAlloc(interp, argc * sizeof(Tcl_DString)); newArgv = TclStackAlloc(interp, (argc+1) * sizeof(char *)); newArgv[argc] = NULL; for (i = 0; i < argc; i++) { newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]); } #ifdef USE_VFORK /* * After vfork(), do not call code in the child that changes global state, * because it is using the parent's memory space at that point and writes * might corrupt the parent: so ensure standard channels are initialized * in the parent, otherwise SetupStdFile() might initialize them in the * child. */ if (!inputFile) { Tcl_GetStdChannel(TCL_STDIN); } if (!outputFile) { Tcl_GetStdChannel(TCL_STDOUT); } if (!errorFile) { Tcl_GetStdChannel(TCL_STDERR); } #endif pid = fork(); if (pid == 0) { size_t len; int joinThisError = errorFile && (errorFile == outputFile); fd = GetFd(errPipeOut); /* * Set up stdio file handles for the child process. */ if (!SetupStdFile(inputFile, TCL_STDIN) || !SetupStdFile(outputFile, TCL_STDOUT) || (!joinThisError && !SetupStdFile(errorFile, TCL_STDERR)) || (joinThisError && ((dup2(1,2) == -1) || (fcntl(2, F_SETFD, 0) != 0)))) { sprintf(errSpace, "%dforked process couldn't set up input/output", errno); len = strlen(errSpace); if (len != (size_t) write(fd, errSpace, len)) { Tcl_Panic("TclpCreateProcess: unable to write to errPipeOut"); } _exit(1); } /* * Close the input side of the error pipe. */ RestoreSignals(); execvp(newArgv[0], newArgv); /* INTL: Native. */ sprintf(errSpace, "%dcouldn't execute \"%.150s\"", errno, argv[0]); len = strlen(errSpace); if (len != (size_t) write(fd, errSpace, len)) { Tcl_Panic("TclpCreateProcess: unable to write to errPipeOut"); } _exit(1); } /* * Free the mem we used for the fork */ for (i = 0; i < argc; i++) { Tcl_DStringFree(&dsArray[i]); } TclStackFree(interp, newArgv); TclStackFree(interp, dsArray); if (pid == -1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't fork child process: %s", Tcl_PosixError(interp))); goto error; } /* * Read back from the error pipe to see if the child started up OK. The * info in the pipe (if any) consists of a decimal errno value followed by * an error message. */ TclpCloseFile(errPipeOut); errPipeOut = NULL; fd = GetFd(errPipeIn); count = read(fd, errSpace, (size_t) (sizeof(errSpace) - 1)); if (count > 0) { char *end; errSpace[count] = 0; errno = strtol(errSpace, &end, 10); Tcl_SetObjResult(interp, Tcl_ObjPrintf("%s: %s", end, Tcl_PosixError(interp))); goto error; } TclpCloseFile(errPipeIn); *pidPtr = (Tcl_Pid) INT2PTR(pid); return TCL_OK; error: if (pid != -1) { /* * Reap the child process now if an error occurred during its startup. * We don't call this with WNOHANG because that can lead to defunct * processes on an MP system. We shouldn't have to worry about hanging * here, since this is the error case. [Bug: 6148] */ Tcl_WaitPid((Tcl_Pid) INT2PTR(pid), &status, 0); } if (errPipeIn) { TclpCloseFile(errPipeIn); } if (errPipeOut) { TclpCloseFile(errPipeOut); } return TCL_ERROR; }
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; const char *path = NULL; Atom selection; const char *selName = NULL; const char *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_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", string)); Tcl_SetErrorCode(interp, "TK", "SELECTION", "VALUE", 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; const 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_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", string)); Tcl_SetErrorCode(interp, "TK", "SELECTION", "VALUE", 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; const char *targetName = NULL; const 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_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", string)); Tcl_SetErrorCode(interp, "TK", "SELECTION", "VALUE", 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 = ckalloc(Tk_Offset(CommandInfo, command) + 1 + cmdLength); cmdInfoPtr->interp = interp; cmdInfoPtr->charOffset = 0; cmdInfoPtr->byteOffset = 0; cmdInfoPtr->buffer[0] = '\0'; cmdInfoPtr->cmdLength = cmdLength; memcpy(cmdInfoPtr->command, string, cmdLength + 1); Tk_CreateSelHandler(tkwin, selection, target, HandleTclCommand, cmdInfoPtr, format); } return TCL_OK; } case SELECTION_OWN: { register LostCommand *lostPtr; Tcl_Obj *commandObj = NULL; 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_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", string)); Tcl_SetErrorCode(interp, "TK", "SELECTION", "VALUE", 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: commandObj = 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_SetObjResult(interp, TkNewWindowObj(infoPtr->owner)); } return TCL_OK; } tkwin = Tk_NameToWindow(interp, Tcl_GetString(objs[0]), tkwin); if (tkwin == NULL) { return TCL_ERROR; } if (count == 2) { commandObj = objs[1]; } if (commandObj == NULL) { Tk_OwnSelection(tkwin, selection, NULL, NULL); return TCL_OK; } lostPtr = ckalloc(sizeof(LostCommand)); lostPtr->interp = interp; lostPtr->cmdObj = commandObj; Tcl_IncrRefCount(commandObj); Tk_OwnSelection(tkwin, selection, LostSelection, lostPtr); return TCL_OK; } } return TCL_OK; }
void Tcl_MainEx( int argc, /* Number of arguments. */ TCHAR **argv, /* Array of argument strings. */ Tcl_AppInitProc *appInitProc, /* Application-specific initialization * function to call after most initialization * but before starting to execute commands. */ Tcl_Interp *interp) { Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; int code, exitCode = 0; Tcl_MainLoopProc *mainLoopProc; Tcl_Channel chan; InteractiveState is; TclpSetInitialEncodings(); TclpFindExecutable((const char *)argv[0]); Tcl_InitMemory(interp); is.interp = interp; is.prompt = PROMPT_START; is.commandPtr = Tcl_NewObj(); /* * If the application has not already set a startup script, parse the * first few command line arguments to determine the script path and * encoding. */ if (NULL == Tcl_GetStartupScript(NULL)) { /* * Check whether first 3 args (argv[1] - argv[3]) look like * -encoding ENCODING FILENAME * or like * FILENAME */ if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1])) && ('-' != argv[3][0])) { Tcl_Obj *value = NewNativeObj(argv[2], -1); Tcl_SetStartupScript(NewNativeObj(argv[3], -1), Tcl_GetString(value)); Tcl_DecrRefCount(value); argc -= 3; argv += 3; } else if ((argc > 1) && ('-' != argv[1][0])) { Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL); argc--; argv++; } } path = Tcl_GetStartupScript(&encodingName); if (path == NULL) { appName = NewNativeObj(argv[0], -1); } else { appName = path; } Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); argc--; argv++; Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY); argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1)); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); /* * Set the "tcl_interactive" variable. */ is.tty = isatty(0); Tcl_SetVar2Ex(interp, "tcl_interactive", NULL, Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. */ Tcl_Preserve(interp); if (appInitProc(interp) != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { Tcl_WriteChars(chan, "application-specific initialization failed: ", -1); Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); Tcl_WriteChars(chan, "\n", 1); } } if (Tcl_InterpDeleted(interp)) { goto done; } if (Tcl_LimitExceeded(interp)) { goto done; } if (TclFullFinalizationRequested()) { /* * Arrange for final deletion of the main interp */ /* ARGH Munchhausen effect */ Tcl_CreateExitHandler(FreeMainInterp, interp); } /* * Invoke the script specified on the command line, if any. Must fetch it * again, as the appInitProc might have reset it. */ path = Tcl_GetStartupScript(&encodingName); if (path != NULL) { Tcl_ResetResult(interp); code = Tcl_FSEvalFileEx(interp, path, encodingName); if (code != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { Tcl_Obj *options = Tcl_GetReturnOptions(interp, code); Tcl_Obj *keyPtr, *valuePtr; TclNewLiteralStringObj(keyPtr, "-errorinfo"); Tcl_IncrRefCount(keyPtr); Tcl_DictObjGet(NULL, options, keyPtr, &valuePtr); Tcl_DecrRefCount(keyPtr); if (valuePtr) { Tcl_WriteObj(chan, valuePtr); } Tcl_WriteChars(chan, "\n", 1); Tcl_DecrRefCount(options); } exitCode = 1; } goto done; } /* * We're running interactively. Source a user-specific startup file if the * application specified one and if the file exists. */ Tcl_SourceRCFile(interp); if (Tcl_LimitExceeded(interp)) { goto done; } /* * Process commands from stdin until there's an end-of-file. Note that we * need to fetch the standard channels again after every eval, since they * may have been changed. */ Tcl_IncrRefCount(is.commandPtr); /* * Get a new value for tty if anyone writes to ::tcl_interactive */ Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN); is.input = Tcl_GetStdChannel(TCL_STDIN); while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) { mainLoopProc = TclGetMainLoop(); if (mainLoopProc == NULL) { int length; if (is.tty) { Prompt(interp, &is); if (Tcl_InterpDeleted(interp)) { break; } if (Tcl_LimitExceeded(interp)) { break; } is.input = Tcl_GetStdChannel(TCL_STDIN); if (is.input == NULL) { break; } } if (Tcl_IsShared(is.commandPtr)) { Tcl_DecrRefCount(is.commandPtr); is.commandPtr = Tcl_DuplicateObj(is.commandPtr); Tcl_IncrRefCount(is.commandPtr); } length = Tcl_GetsObj(is.input, is.commandPtr); if (length < 0) { if (Tcl_InputBlocked(is.input)) { /* * This can only happen if stdin has been set to * non-blocking. In that case cycle back and try again. * This sets up a tight polling loop (since we have no * event loop running). If this causes bad CPU hogging, we * might try toggling the blocking on stdin instead. */ continue; } /* * Either EOF, or an error on stdin; we're done */ break; } /* * Add the newline removed by Tcl_GetsObj back to the string. Have * to add it back before testing completeness, because it can make * a difference. [Bug 1775878] */ if (Tcl_IsShared(is.commandPtr)) { Tcl_DecrRefCount(is.commandPtr); is.commandPtr = Tcl_DuplicateObj(is.commandPtr); Tcl_IncrRefCount(is.commandPtr); } Tcl_AppendToObj(is.commandPtr, "\n", 1); if (!TclObjCommandComplete(is.commandPtr)) { is.prompt = PROMPT_CONTINUE; continue; } is.prompt = PROMPT_START; /* * The final newline is syntactically redundant, and causes some * error messages troubles deeper in, so lop it back off. */ Tcl_GetStringFromObj(is.commandPtr, &length); Tcl_SetObjLength(is.commandPtr, --length); code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL); is.input = Tcl_GetStdChannel(TCL_STDIN); Tcl_DecrRefCount(is.commandPtr); is.commandPtr = Tcl_NewObj(); Tcl_IncrRefCount(is.commandPtr); if (code != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); Tcl_WriteChars(chan, "\n", 1); } } else if (is.tty) { resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); Tcl_GetStringFromObj(resultPtr, &length); chan = Tcl_GetStdChannel(TCL_STDOUT); if ((length > 0) && chan) { Tcl_WriteObj(chan, resultPtr); Tcl_WriteChars(chan, "\n", 1); } Tcl_DecrRefCount(resultPtr); } } else { /* (mainLoopProc != NULL) */ /* * If a main loop has been defined while running interactively, we * want to start a fileevent based prompt by establishing a * channel handler for stdin. */ if (is.input) { if (is.tty) { Prompt(interp, &is); } Tcl_CreateChannelHandler(is.input, TCL_READABLE, StdinProc, &is); } mainLoopProc(); Tcl_SetMainLoop(NULL); if (is.input) { Tcl_DeleteChannelHandler(is.input, StdinProc, &is); } is.input = Tcl_GetStdChannel(TCL_STDIN); } /* * This code here only for the (unsupported and deprecated) [checkmem] * command. */ #ifdef TCL_MEM_DEBUG if (tclMemDumpFileName != NULL) { Tcl_SetMainLoop(NULL); Tcl_DeleteInterp(interp); } #endif /* TCL_MEM_DEBUG */ } done: mainLoopProc = TclGetMainLoop(); if ((exitCode == 0) && mainLoopProc && !Tcl_LimitExceeded(interp)) { /* * If everything has gone OK so far, call the main loop proc, if it * exists. Packages (like Tk) can set it to start processing events at * this point. */ mainLoopProc(); Tcl_SetMainLoop(NULL); } if (is.commandPtr != NULL) { Tcl_DecrRefCount(is.commandPtr); } /* * Rather than calling exit, invoke the "exit" command so that users can * replace "exit" with some other command to do additional cleanup on * exit. The Tcl_EvalObjEx call should never return. */ if (!Tcl_InterpDeleted(interp) && !Tcl_LimitExceeded(interp)) { Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode); Tcl_IncrRefCount(cmd); Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL); Tcl_DecrRefCount(cmd); } /* * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual is * happening. Maybe interp has been deleted; maybe [exit] was redefined, * maybe we've blown up because of an exceeded limit. We still want to * cleanup and exit. */ Tcl_Exit(exitCode); }
static int TtyParseMode( Tcl_Interp *interp, /* If non-NULL, interp for error return. */ const char *mode, /* Mode string to be parsed. */ TtyAttrs *ttyPtr) /* Filled with data from mode string */ { int i, end; char parity; const char *bad = "bad value for -mode"; i = sscanf(mode, "%d,%c,%d,%d%n", &ttyPtr->baud, &parity, &ttyPtr->data, &ttyPtr->stop, &end); if ((i != 4) || (mode[end] != '\0')) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s: should be baud,parity,data,stop", bad)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; } /* * Only allow setting mark/space parity on platforms that support it Make * sure to allow for the case where strchr is a macro. [Bug: 5089] * * We cannot if/else/endif the strchr arguments, it has to be the whole * function. On AIX this function is apparently a macro, and macros do * not allow pre-processor directives in their arguments. */ if ( #if defined(PAREXT) strchr("noems", parity) #else strchr("noe", parity) #endif /* PAREXT */ == NULL) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s parity: should be %s", bad, #if defined(PAREXT) "n, o, e, m, or s" #else "n, o, or e" #endif /* PAREXT */ )); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; } ttyPtr->parity = parity; if ((ttyPtr->data < 5) || (ttyPtr->data > 8)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s data: should be 5, 6, 7, or 8", bad)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; } if ((ttyPtr->stop < 0) || (ttyPtr->stop > 2)) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s stop: should be 1 or 2", bad)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL); } return TCL_ERROR; } return TCL_OK; }
static int TcpConnect( Tcl_Interp *interp, /* For error reporting; can be NULL. */ TcpState *statePtr) { socklen_t optlen; int async_callback = statePtr->flags & TCP_ASYNC_PENDING; int ret = -1, error = errno; int async = statePtr->flags & TCP_ASYNC_CONNECT; if (async_callback) { goto reenter; } for (statePtr->addr = statePtr->addrlist; statePtr->addr != NULL; statePtr->addr = statePtr->addr->ai_next) { for (statePtr->myaddr = statePtr->myaddrlist; statePtr->myaddr != NULL; statePtr->myaddr = statePtr->myaddr->ai_next) { int reuseaddr = 1; /* * No need to try combinations of local and remote addresses of * different families. */ if (statePtr->myaddr->ai_family != statePtr->addr->ai_family) { continue; } /* * Close the socket if it is still open from the last unsuccessful * iteration. */ if (statePtr->fds.fd >= 0) { close(statePtr->fds.fd); statePtr->fds.fd = -1; errno = 0; } statePtr->fds.fd = socket(statePtr->addr->ai_family, SOCK_STREAM, 0); if (statePtr->fds.fd < 0) { continue; } /* * Set the close-on-exec flag so that the socket will not get * inherited by child processes. */ fcntl(statePtr->fds.fd, F_SETFD, FD_CLOEXEC); /* * Set kernel space buffering */ TclSockMinimumBuffers(INT2PTR(statePtr->fds.fd), SOCKET_BUFSIZE); if (async) { ret = TclUnixSetBlockingMode(statePtr->fds.fd,TCL_MODE_NONBLOCKING); if (ret < 0) { continue; } } /* Gotta reset the error variable here, before we use it for the * first time in this iteration. */ error = 0; (void) setsockopt(statePtr->fds.fd, SOL_SOCKET, SO_REUSEADDR, (char *) &reuseaddr, sizeof(reuseaddr)); ret = bind(statePtr->fds.fd, statePtr->myaddr->ai_addr, statePtr->myaddr->ai_addrlen); if (ret < 0) { error = errno; continue; } /* * Attempt to connect. The connect may fail at present with an * EINPROGRESS but at a later time it will complete. The caller * will set up a file handler on the socket if she is interested * in being informed when the connect completes. */ ret = connect(statePtr->fds.fd, statePtr->addr->ai_addr, statePtr->addr->ai_addrlen); if (ret < 0) error = errno; if (ret < 0 && errno == EINPROGRESS) { Tcl_CreateFileHandler(statePtr->fds.fd, TCL_WRITABLE|TCL_EXCEPTION, TcpAsyncCallback, statePtr); errno = EWOULDBLOCK; SET_BITS(statePtr->flags, TCP_ASYNC_PENDING); return TCL_OK; reenter: CLEAR_BITS(statePtr->flags, TCP_ASYNC_PENDING); Tcl_DeleteFileHandler(statePtr->fds.fd); /* * Read the error state from the socket to see if the async * connection has succeeded or failed. As this clears the * error condition, we cache the status in the socket state * struct for later retrieval by [fconfigure -error]. */ optlen = sizeof(int); getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, (char *) &error, &optlen); errno = error; } if (error == 0) { goto out; } } } out: statePtr->connectError = error; CLEAR_BITS(statePtr->flags, TCP_ASYNC_CONNECT); if (async_callback) { /* * An asynchonous connection has finally succeeded or failed. */ TcpWatchProc(statePtr, statePtr->filehandlers); TclUnixSetBlockingMode(statePtr->fds.fd, statePtr->cachedBlocking); if (error != 0) { SET_BITS(statePtr->flags, TCP_ASYNC_FAILED); } /* * We need to forward the writable event that brought us here, bcasue * upon reading of getsockopt(SO_ERROR), at least some OSes clear the * writable state from the socket, and so a subsequent select() on * behalf of a script level [fileevent] would not fire. It doesn't * hurt that this is also called in the successful case and will save * the event mechanism one roundtrip through select(). */ if (statePtr->cachedBlocking == TCL_MODE_NONBLOCKING) { Tcl_NotifyChannel(statePtr->channel, TCL_WRITABLE); } } if (error != 0) { /* * Failure for either a synchronous connection, or an async one that * failed before it could enter background mode, e.g. because an * invalid -myaddr was given. */ if (interp != NULL) { errno = error; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open socket: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } return TCL_OK; }
Tcl_Channel TclpOpenFileChannel( Tcl_Interp *interp, /* Interpreter for error reporting; can be * NULL. */ Tcl_Obj *pathPtr, /* Name of file to open. */ int mode, /* POSIX open mode. */ int permissions) /* If the open involves creating a file, with * what modes to create it? */ { int fd, channelPermissions; FileState *fsPtr; const char *native, *translation; char channelName[16 + TCL_INTEGER_SPACE]; const Tcl_ChannelType *channelTypePtr; switch (mode & (O_RDONLY | O_WRONLY | O_RDWR)) { case O_RDONLY: channelPermissions = TCL_READABLE; break; case O_WRONLY: channelPermissions = TCL_WRITABLE; break; case O_RDWR: channelPermissions = (TCL_READABLE | TCL_WRITABLE); break; default: /* * This may occurr if modeString was "", for example. */ Tcl_Panic("TclpOpenFileChannel: invalid mode value"); return NULL; } native = Tcl_FSGetNativePath(pathPtr); if (native == NULL) { if (interp != (Tcl_Interp *) NULL) { Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), "\": filename is invalid on this platform", NULL); } return NULL; } #ifdef DJGPP SET_BITS(mode, O_BINARY); #endif fd = TclOSopen(native, mode, permissions); if (fd < 0) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't open \"%s\": %s", TclGetString(pathPtr), Tcl_PosixError(interp))); } return NULL; } /* * Set close-on-exec flag on the fd so that child processes will not * inherit this fd. */ fcntl(fd, F_SETFD, FD_CLOEXEC); sprintf(channelName, "file%d", fd); #ifdef SUPPORTS_TTY if (strcmp(native, "/dev/tty") != 0 && isatty(fd)) { /* * Initialize the serial port to a set of sane parameters. Especially * important if the remote device is set to echo and the serial port * driver was also set to echo -- as soon as a char were sent to the * serial port, the remote device would echo it, then the serial * driver would echo it back to the device, etc. * * Note that we do not do this if we're dealing with /dev/tty itself, * as that tends to cause Bad Things To Happen when you're working * interactively. Strictly a better check would be to see if the FD * being set up is a device and has the same major/minor as the * initial std FDs (beware reopening!) but that's nearly as messy. */ translation = "auto crlf"; channelTypePtr = &ttyChannelType; TtyInit(fd); } else #endif /* SUPPORTS_TTY */ { translation = NULL; channelTypePtr = &fileChannelType; } fsPtr = ckalloc(sizeof(FileState)); fsPtr->validMask = channelPermissions | TCL_EXCEPTION; fsPtr->fd = fd; fsPtr->channel = Tcl_CreateChannel(channelTypePtr, channelName, fsPtr, channelPermissions); if (translation != NULL) { /* * Gotcha. Most modems need a "\r" at the end of the command sequence. * If you just send "at\n", the modem will not respond with "OK" * because it never got a "\r" to actually invoke the command. So, by * default, newlines are translated to "\r\n" on output to avoid "bug" * reports that the serial port isn't working. */ if (Tcl_SetChannelOption(interp, fsPtr->channel, "-translation", translation) != TCL_OK) { Tcl_Close(NULL, fsPtr->channel); return NULL; } } return fsPtr->channel; }
static int TcpGetOptionProc( ClientData instanceData, /* Socket state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Name of the option to retrieve the value * for, or NULL to get all options and their * values. */ Tcl_DString *dsPtr) /* Where to store the computed value; * initialized by caller. */ { TcpState *statePtr = instanceData; size_t len = 0; WaitForConnect(statePtr, NULL); if (optionName != NULL) { len = strlen(optionName); } if ((len > 1) && (optionName[1] == 'e') && (strncmp(optionName, "-error", len) == 0)) { socklen_t optlen = sizeof(int); if (statePtr->flags & TCP_ASYNC_CONNECT) { /* Suppress errors as long as we are not done */ errno = 0; } else if (statePtr->connectError != 0) { errno = statePtr->connectError; statePtr->connectError = 0; } else { int err; getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR, (char *) &err, &optlen); errno = err; } if (errno != 0) { Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(errno), -1); } return TCL_OK; } if ((len > 1) && (optionName[1] == 'c') && (strncmp(optionName, "-connecting", len) == 0)) { Tcl_DStringAppend(dsPtr, (statePtr->flags & TCP_ASYNC_CONNECT) ? "1" : "0", -1); return TCL_OK; } if ((len == 0) || ((len > 1) && (optionName[1] == 'p') && (strncmp(optionName, "-peername", len) == 0))) { address peername; socklen_t size = sizeof(peername); if ( (statePtr->flags & TCP_ASYNC_CONNECT) ) { /* * In async connect output an empty string */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringAppendElement(dsPtr, ""); } else { return TCL_OK; } } else if (getpeername(statePtr->fds.fd, &peername.sa, &size) >= 0) { /* * Peername fetch succeeded - output list */ if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-peername"); Tcl_DStringStartSublist(dsPtr); } TcpHostPortList(interp, dsPtr, peername, size); if (len) { return TCL_OK; } Tcl_DStringEndSublist(dsPtr); } else { /* * getpeername failed - but if we were asked for all the options * (len==0), don't flag an error at that point because it could be * an fconfigure request on a server socket (which have no peer). * Same must be done on win&mac. */ if (len) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't get peername: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } } } if ((len == 0) || ((len > 1) && (optionName[1] == 's') && (strncmp(optionName, "-sockname", len) == 0))) { TcpFdList *fds; address sockname; socklen_t size; int found = 0; if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-sockname"); Tcl_DStringStartSublist(dsPtr); } if ( (statePtr->flags & TCP_ASYNC_CONNECT) ) { /* * In async connect output an empty string */ found = 1; } else { for (fds = &statePtr->fds; fds != NULL; fds = fds->next) { size = sizeof(sockname); if (getsockname(fds->fd, &(sockname.sa), &size) >= 0) { found = 1; TcpHostPortList(interp, dsPtr, sockname, size); } } } if (found) { if (len) { return TCL_OK; } Tcl_DStringEndSublist(dsPtr); } else { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't get sockname: %s", Tcl_PosixError(interp))); } return TCL_ERROR; } } if (len > 0) { return Tcl_BadChannelOption(interp, optionName, "connecting peername sockname"); } return TCL_OK; }
int Tcl_GetOpenFile( Tcl_Interp *interp, /* Interpreter in which to find file. */ const char *chanID, /* String that identifies file. */ int forWriting, /* 1 means the file is going to be used for * writing, 0 means for reading. */ int checkUsage, /* 1 means verify that the file was opened in * a mode that allows the access specified by * "forWriting". Ignored, we always check that * the channel is open for the requested * mode. */ ClientData *filePtr) /* Store pointer to FILE structure here. */ { Tcl_Channel chan; int chanMode, fd; const Tcl_ChannelType *chanTypePtr; ClientData data; FILE *f; chan = Tcl_GetChannel(interp, chanID, &chanMode); if (chan == NULL) { return TCL_ERROR; } if (forWriting && !(chanMode & TCL_WRITABLE)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" wasn't opened for writing", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_WRITABLE", NULL); return TCL_ERROR; } else if (!forWriting && !(chanMode & TCL_READABLE)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" wasn't opened for reading", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_READABLE", NULL); return TCL_ERROR; } /* * We allow creating a FILE * out of file based, pipe based and socket * based channels. We currently do not allow any other channel types, * because it is likely that stdio will not know what to do with them. */ chanTypePtr = Tcl_GetChannelType(chan); if ((chanTypePtr == &fileChannelType) #ifdef SUPPORTS_TTY || (chanTypePtr == &ttyChannelType) #endif /* SUPPORTS_TTY */ || (strcmp(chanTypePtr->typeName, "tcp") == 0) || (strcmp(chanTypePtr->typeName, "pipe") == 0)) { if (Tcl_GetChannelHandle(chan, (forWriting ? TCL_WRITABLE : TCL_READABLE), &data) == TCL_OK) { fd = PTR2INT(data); /* * The call to fdopen below is probably dangerous, since it will * truncate an existing file if the file is being opened for * writing.... */ f = fdopen(fd, (forWriting ? "w" : "r")); if (f == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "cannot get a FILE * for \"%s\"", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "FILE_FAILURE", NULL); return TCL_ERROR; } *filePtr = f; return TCL_OK; } } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" cannot be used to get a FILE *", chanID)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NO_DESCRIPTOR", NULL); return TCL_ERROR; }
/* 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; }
static int TtySetOptionProc( ClientData instanceData, /* File state. */ Tcl_Interp *interp, /* For error reporting - can be NULL. */ const char *optionName, /* Which option to set? */ const char *value) /* New value for option. */ { FileState *fsPtr = instanceData; unsigned int len, vlen; TtyAttrs tty; int argc; const char **argv; struct termios iostate; len = strlen(optionName); vlen = strlen(value); /* * Option -mode baud,parity,databits,stopbits */ if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) { if (TtyParseMode(interp, value, &tty) != TCL_OK) { return TCL_ERROR; } /* * system calls results should be checked there. - dl */ TtySetAttributes(fsPtr->fd, &tty); return TCL_OK; } /* * Option -handshake none|xonxoff|rtscts|dtrdsr */ if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) { /* * Reset all handshake options. DTR and RTS are ON by default. */ tcgetattr(fsPtr->fd, &iostate); CLEAR_BITS(iostate.c_iflag, IXON | IXOFF | IXANY); #ifdef CRTSCTS CLEAR_BITS(iostate.c_cflag, CRTSCTS); #endif /* CRTSCTS */ if (Tcl_UtfNcasecmp(value, "NONE", vlen) == 0) { /* * Leave all handshake options disabled. */ } else if (Tcl_UtfNcasecmp(value, "XONXOFF", vlen) == 0) { SET_BITS(iostate.c_iflag, IXON | IXOFF | IXANY); } else if (Tcl_UtfNcasecmp(value, "RTSCTS", vlen) == 0) { #ifdef CRTSCTS SET_BITS(iostate.c_cflag, CRTSCTS); #else /* !CRTSTS */ UNSUPPORTED_OPTION("-handshake RTSCTS"); return TCL_ERROR; #endif /* CRTSCTS */ } else if (Tcl_UtfNcasecmp(value, "DTRDSR", vlen) == 0) { UNSUPPORTED_OPTION("-handshake DTRDSR"); return TCL_ERROR; } else { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -handshake: must be one of" " xonxoff, rtscts, dtrdsr or none", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } return TCL_ERROR; } tcsetattr(fsPtr->fd, TCSADRAIN, &iostate); return TCL_OK; } /* * Option -xchar {\x11 \x13} */ if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) { Tcl_DString ds; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; } else if (argc != 2) { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -xchar: should be a list of" " two elements", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } ckfree(argv); return TCL_ERROR; } tcgetattr(fsPtr->fd, &iostate); Tcl_UtfToExternalDString(NULL, argv[0], -1, &ds); iostate.c_cc[VSTART] = *(const cc_t *) Tcl_DStringValue(&ds); TclDStringClear(&ds); Tcl_UtfToExternalDString(NULL, argv[1], -1, &ds); iostate.c_cc[VSTOP] = *(const cc_t *) Tcl_DStringValue(&ds); Tcl_DStringFree(&ds); ckfree(argv); tcsetattr(fsPtr->fd, TCSADRAIN, &iostate); return TCL_OK; } /* * Option -timeout msec */ if ((len > 2) && (strncmp(optionName, "-timeout", len) == 0)) { int msec; tcgetattr(fsPtr->fd, &iostate); if (Tcl_GetInt(interp, value, &msec) != TCL_OK) { return TCL_ERROR; } iostate.c_cc[VMIN] = 0; iostate.c_cc[VTIME] = (msec==0) ? 0 : (msec<100) ? 1 : (msec+50)/100; tcsetattr(fsPtr->fd, TCSADRAIN, &iostate); return TCL_OK; } /* * Option -ttycontrol {DTR 1 RTS 0 BREAK 0} */ if ((len > 4) && (strncmp(optionName, "-ttycontrol", len) == 0)) { #if defined(TIOCMGET) && defined(TIOCMSET) int i, control, flag; if (Tcl_SplitList(interp, value, &argc, &argv) == TCL_ERROR) { return TCL_ERROR; } if ((argc % 2) == 1) { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "bad value for -ttycontrol: should be a list of" " signal,value pairs", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } ckfree(argv); return TCL_ERROR; } ioctl(fsPtr->fd, TIOCMGET, &control); for (i = 0; i < argc-1; i += 2) { if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) { ckfree(argv); return TCL_ERROR; } if (Tcl_UtfNcasecmp(argv[i], "DTR", strlen(argv[i])) == 0) { if (flag) { SET_BITS(control, TIOCM_DTR); } else { CLEAR_BITS(control, TIOCM_DTR); } } else if (Tcl_UtfNcasecmp(argv[i], "RTS", strlen(argv[i])) == 0) { if (flag) { SET_BITS(control, TIOCM_RTS); } else { CLEAR_BITS(control, TIOCM_RTS); } } else if (Tcl_UtfNcasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) { #if defined(TIOCSBRK) && defined(TIOCCBRK) if (flag) { ioctl(fsPtr->fd, TIOCSBRK, NULL); } else { ioctl(fsPtr->fd, TIOCCBRK, NULL); } #else /* TIOCSBRK & TIOCCBRK */ UNSUPPORTED_OPTION("-ttycontrol BREAK"); ckfree(argv); return TCL_ERROR; #endif /* TIOCSBRK & TIOCCBRK */ } else { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad signal \"%s\" for -ttycontrol: must be" " DTR, RTS or BREAK", argv[i])); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE", "VALUE", NULL); } ckfree(argv); return TCL_ERROR; } } /* -ttycontrol options loop */ ioctl(fsPtr->fd, TIOCMSET, &control); ckfree(argv); return TCL_OK; #else /* TIOCMGET&TIOCMSET */ UNSUPPORTED_OPTION("-ttycontrol"); #endif /* TIOCMGET&TIOCMSET */ } return Tcl_BadChannelOption(interp, optionName, "mode handshake timeout ttycontrol xchar"); }