Esempio n. 1
0
/*
  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;
}
Esempio n. 2
0
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;
}
Esempio n. 3
0
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;
}
Esempio n. 4
0
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;
}
Esempio n. 5
0
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;
}
Esempio n. 6
0
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;
}
Esempio n. 7
0
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;
}
Esempio n. 8
0
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;
}
Esempio n. 9
0
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;
}
Esempio n. 10
0
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;
}
Esempio n. 11
0
	/* 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;
}
Esempio n. 12
0
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;
}
Esempio n. 13
0
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;
}
Esempio n. 14
0
File: tkGrab.c Progetto: tcltk/tk
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;
}
Esempio n. 15
0
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;
}
Esempio n. 16
0
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);
}
Esempio n. 17
0
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;
}
Esempio n. 18
0
static int
HandleTclCommand(
    ClientData clientData,	/* Information about command to execute. */
    int offset,			/* Return selection bytes starting at this
				 * offset. */
    char *buffer,		/* Place to store converted selection. */
    int maxBytes)		/* Maximum # of bytes to store at buffer. */
{
    CommandInfo *cmdInfoPtr = clientData;
    int length;
    Tcl_Obj *command;
    const char *string;
    Tcl_Interp *interp = cmdInfoPtr->interp;
    Tcl_InterpState savedState;
    int extraBytes, charOffset, count, numChars, code;
    const char *p;

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

    Tcl_Preserve(clientData);
    Tcl_Preserve(interp);

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

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

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

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

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

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

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

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

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

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

    Tcl_Release(clientData);
    Tcl_Release(interp);
    return count;
}
Esempio n. 19
0
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;
}
Esempio n. 20
0
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;
}
Esempio n. 21
0
/* 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;
}
Esempio n. 22
0
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;
}
Esempio n. 23
0
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);
}
Esempio n. 24
0
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;
}
Esempio n. 25
0
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;
}
Esempio n. 26
0
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;
}
Esempio n. 27
0
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;
}
Esempio n. 28
0
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;
}
Esempio n. 29
0
	/* 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;
}
Esempio n. 30
0
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");
}