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

/*
 * Public functions that are not accessible via the stubs table.
 * Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171]
 */

#define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \
	    ((Tcl_CreateInterp)()))
EXTERN void		Tcl_MainEx(int argc, char **argv,
			    Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
EXTERN const char *	Tcl_PkgInitStubsCheck(Tcl_Interp *interp,
			    const char *version, int exact);
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
EXTERN void		Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
#endif

 * 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. */
    const 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;
    const Tcl_Config *cfg;

    QCCD *cdPtr = 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 *const 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 ?arg?");
	return TCL_ERROR;
    }
    if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0,
	    &index) != TCL_OK) {

		|| val == NULL) {
	    Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
		    Tcl_GetString(objv[2]), NULL);
	    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 = 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.

    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();

    /*

    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_MainEx(argc, argv, appInitProc, Tcl_CreateInterp());
}
#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */

#ifndef TCL_ASCII_MAIN

/*