Tcl Source Code

2013-06-27  Jan Nijtmans  <[email protected]>

	* generic/tclConfig.c: Bug [9b2e636361]: Tcl_CreateInterp() needs initialized
	* generic/tclMain.c:   encodings.

2013-06-18  Jan Nijtmans  <[email protected]>

	* generic/tclEvent.c: Bug [3611974]: InitSubsystems multiple thread issue.

2013-06-17  Jan Nijtmans  <[email protected]>

	* generic/regc_locale.c: Bug [a876646efe]: re_expr character class

 * values are in UTF-8, converted from the external representation given to us
 * by the caller.
 */

#define ASSOC_KEY	"tclPackageAboutDict"

/*
 * A ClientData struct for the QueryConfig command.  Store the three bits
 * of data we need; the package name for which we store a config dict,
 * the (Tcl_Interp *) in which it is stored, and the encoding.
 */

typedef struct QCCD {
    Tcl_Obj *pkg;
    Tcl_Interp *interp;
    char *encoding;
} QCCD;

/*
 * Static functions in this file:
 */

static int		QueryConfigObjCmd(ClientData clientData,

    CONST char *pkgName,	/* Name of the package registering the
				 * embedded configuration. ASCII, thus in
				 * UTF-8 too. */
    Tcl_Config *configuration,	/* Embedded configuration. */
    CONST char *valEncoding)	/* Name of the encoding used to store the
				 * configuration values, ASCII, thus UTF-8. */
{
    Tcl_Obj *pDB, *pkgDict;
    Tcl_DString cmdName;
    Tcl_Config *cfg;

    QCCD *cdPtr = (QCCD *)ckalloc(sizeof(QCCD));

    cdPtr->interp = interp;
    if (valEncoding) {
	cdPtr->encoding = ckalloc(strlen(valEncoding)+1);
	strcpy(cdPtr->encoding, valEncoding);
    } else {
	cdPtr->encoding = NULL;
    }
    cdPtr->pkg = Tcl_NewStringObj(pkgName, -1);

    /*
     * Phase I: Adding the provided information to the internal database of
     * package meta data.
     *
     * Phase II: Create a command for querying this database, specific to the
     * package registering its configuration. This is the approved interface
     * in TIP 59. In the future a more general interface should be done, as
     * follow-up to TIP 59. Simply because our database is now general across
     * packages, and not a structure tied to one package.
     *
     * Note, the created command will have a reference through its clientdata.
     */

    Tcl_IncrRefCount(cdPtr->pkg);

    /*
     * For venc == NULL aka bogus encoding we skip the step setting up the
     * dictionaries visible at Tcl level. I.e. they are not filled
     */


    pDB = GetConfigDict(interp);

    /*
     * Retrieve package specific configuration...
     */

    if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK
	    || (pkgDict == NULL)) {
	pkgDict = Tcl_NewDictObj();
    } else if (Tcl_IsShared(pkgDict)) {
	pkgDict = Tcl_DuplicateObj(pkgDict);
    }

    /*
     * Extend the package configuration...
     * We cannot assume that the encodings are initialized, therefore
     * store the value as-is in a byte array. See Bug [9b2e636361].
     */

    for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {









	Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),



		Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value)));



    }


    /*
     * Write the changes back into the overall database.
     */

    Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict);


    /*
     * Now create the interface command for retrieval of the package
     * information.
     */

    Tcl_DStringInit(&cmdName);

    int n, index;
    static CONST char *subcmdStrings[] = {
	"get", "list", NULL
    };
    enum subcmds {
	CFG_GET, CFG_LIST
    };
    Tcl_DString conv;
    Tcl_Encoding venc = NULL;
    CONST char *value;

    if ((objc < 2) || (objc > 3)) {
	Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?argument?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0,
	    &index) != TCL_OK) {

	if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK
		|| val == NULL) {
	    Tcl_SetResult(interp, "key not known", TCL_STATIC);
	    return TCL_ERROR;
	}

	if (cdPtr->encoding) {
	    venc = Tcl_GetEncoding(interp, cdPtr->encoding);
	    if (!venc) {
		return TCL_ERROR;
	    }
	}
	/*
	 * Value is stored as-is in a byte array, see Bug [9b2e636361],
	 * so we have to decode it first.
	 */
	value = (const char *) Tcl_GetByteArrayFromObj(val, &n);
	value = Tcl_ExternalToUtfDString(venc, value, n, &conv);
	Tcl_SetObjResult(interp, Tcl_NewStringObj(value,
		Tcl_DStringLength(&conv)));
	Tcl_DStringFree(&conv);
	return TCL_OK;

    case CFG_LIST:
	if (objc != 2) {
	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
	    return TCL_ERROR;
	}

{
    QCCD *cdPtr = (QCCD *) clientData;
    Tcl_Obj *pkgName = cdPtr->pkg;
    Tcl_Obj *pDB = GetConfigDict(cdPtr->interp);

    Tcl_DictObjRemove(NULL, pDB, pkgName);
    Tcl_DecrRefCount(pkgName);
    if (cdPtr->encoding) {
	ckfree((char *)cdPtr->encoding);
    }
    ckfree((char *)cdPtr);
}

/*
 *-------------------------------------------------------------------------
 *
 * GetConfigDict --

/*
 *----------------------------------------------------------------------
 *
 * ConfigDictDeleteProc --
 *
 *	This function is associated with the "Package About dict" assoc data
 *	for an interpreter; it is invoked when the interpreter is deleted in
 *	order to free the information associated with any pending error
 *	reports.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The package metadata database is freed.

    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;

    interp = Tcl_CreateInterp();
    TclpSetInitialEncodings();
    TclpFindExecutable(argv[0]);


    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.
     */