Tcl Extension Architecture (TEA) Sample Extension

 * Create struct with thread local data.
 * This mechanism is called "clientData" in Tcl.
 * We use two of them. One for the sha1 command which holds the context queue.
 * Another for the init command to store the command tolkens to delete them on
 * unload.
 */

struct Sha1ClientData {
    /* State of sha1 command */
    int numcontexts;
    SHA1_CTX *sha1Contexts;
    Tcl_Size *ctxtotalRead;
};

struct CmdClientData {
    /* Tokens of the created commands to delete them on unload */
    Tcl_Command sha1CmdTolken;
    Tcl_Command buildInfoCmdTolken;
};

/* Prototype of the function executed by command "sha1" */

static int Sha1_Cmd(void *clientData, Tcl_Interp *interp,
		int objc, Tcl_Obj *const objv[]);

#define DIGESTSIZE 20

Sha1_Cmd(
    ClientData clientData,	/* Client data with thread local state */
    Tcl_Interp *interp,		/* Current interpreter */
    int objc,			/* Number of arguments */
    Tcl_Obj *const objv[]	/* Argument strings */
    )
{
    /*
     * Get my thread local memory
     */

    struct Sha1ClientData *sha1ClientDataPtr = clientData;

    /*
     * The default base is hex
     */

    int log2base = 4;
    int a;
    Tcl_Obj *stringObj = NULL;
    Tcl_Channel chan = NULL;
    Tcl_Channel copychan = NULL;
    int mode;
    int contextnum = 0;

    char *bufPtr;
    Tcl_WideInt maxbytes = 0;
    int doinit = 1;
    int dofinal = 1;
    Tcl_Obj *descriptorObj = NULL;
    Tcl_Size totalRead = 0, n;
    int i, j, mask, bits, offset;


    /*
     * For binary representation + null char
     */

    char buf[129];
    unsigned char digest[DIGESTSIZE];

	 * Everything except -init takes an argument...
	 */
	if ((index != SHAOPT_INIT) && (++a >= objc)) {
	    goto wrongArgs;
	}
	switch ((enum ShaOpts) index) {
	case SHAOPT_INIT:
	    for (contextnum = 1; contextnum < sha1ClientDataPtr->numcontexts; contextnum++) {
		if (sha1ClientDataPtr->ctxtotalRead[contextnum] == -1) {
		    break;
		}
	    }
	    if (contextnum == sha1ClientDataPtr->numcontexts) {
		/*
		 * Allocate a new context.
		 */

		sha1ClientDataPtr->numcontexts++;
		sha1ClientDataPtr->sha1Contexts = (SHA1_CTX *) ckrealloc(
			(void *) sha1ClientDataPtr->sha1Contexts,
			sha1ClientDataPtr->numcontexts * sizeof(SHA1_CTX));
		sha1ClientDataPtr->ctxtotalRead = (Tcl_Size *)ckrealloc(
			sha1ClientDataPtr->ctxtotalRead,
			sha1ClientDataPtr->numcontexts * sizeof(Tcl_Size));
	    }
	    sha1ClientDataPtr->ctxtotalRead[contextnum] = 0;
	    SHA1Init(&sha1ClientDataPtr->sha1Contexts[contextnum]);
	    snprintf(buf, sizeof(buf), "sha1%d", contextnum);
	    Tcl_AppendResult(interp, buf, NULL);
	    return TCL_OK;
	case SHAOPT_CHAN:
	    chan = Tcl_GetChannel(interp, Tcl_GetString(objv[a]), &mode);
	    if (chan == NULL) {
		return TCL_ERROR;

	    dofinal = 0;
	    continue;
	}
    }

    if (descriptorObj != NULL) {
	if ((sscanf(Tcl_GetString(descriptorObj), "sha1%d",
		&contextnum) != 1) || (contextnum >= sha1ClientDataPtr->numcontexts) ||
		(sha1ClientDataPtr->ctxtotalRead[contextnum] == -1)) {
	    Tcl_AppendResult(interp, "invalid sha1 descriptor \"",
		    Tcl_GetString(descriptorObj), "\"", NULL);
	    return TCL_ERROR;
	}
    }

    if (doinit) {
	SHA1Init(&sha1ClientDataPtr->sha1Contexts[contextnum]);
    }

    if (stringObj != NULL) {
	char *string;
	if (chan != NULL) {
	    goto wrongArgs;
	}
	string = Tcl_GetStringFromObj(stringObj, &totalRead);
	SHA1Update(&sha1ClientDataPtr->sha1Contexts[contextnum],
		(unsigned char *) string, totalRead);
    } else if (chan != NULL) {
	bufPtr = (char *)ckalloc(TCL_READ_CHUNK_SIZE);
	totalRead = 0;
	/*
	 * FIXME: MS-VC 2015 gives the following warning in the next line I
	 * was not able to fix (translated from German):
	 * warning C4244: "Function": Conversion of "Tcl_WideInt" to "int",
	 * possible data loss
	 */
	while ((n = Tcl_Read(chan, bufPtr,
		maxbytes == 0
		? TCL_READ_CHUNK_SIZE
		: (TCL_READ_CHUNK_SIZE < maxbytes
		? TCL_READ_CHUNK_SIZE
		: maxbytes))) != 0) {
	    if (n == -1) {
		ckfree(bufPtr);
		Tcl_AppendResult(interp, Tcl_GetString(objv[0]), ": ",
			Tcl_GetChannelName(chan), Tcl_PosixError(interp),
			NULL);
		return TCL_ERROR;
	    }

	    totalRead += n;

	    SHA1Update(&sha1ClientDataPtr->sha1Contexts[contextnum],
		    (unsigned char *) bufPtr, n);

	    if (copychan != NULL) {
		n = Tcl_Write(copychan, bufPtr, n);
		if (n == -1) {
		    ckfree(bufPtr);
		    Tcl_AppendResult(interp, Tcl_GetString(objv[0]), ": ",
			    Tcl_GetChannelName(copychan),

	}
	ckfree(bufPtr);
    } else if (descriptorObj == NULL) {
	goto wrongArgs;
    }

    if (!dofinal) {
	sha1ClientDataPtr->ctxtotalRead[contextnum] += totalRead;
	Tcl_SetObjResult(interp, Tcl_NewWideIntObj(totalRead));
	return TCL_OK;
    }

    if (stringObj == NULL) {
	totalRead += sha1ClientDataPtr->ctxtotalRead[contextnum];
	Tcl_SetObjResult(interp, Tcl_NewWideIntObj(totalRead));
    }

    SHA1Final(&sha1ClientDataPtr->sha1Contexts[contextnum], digest);

    /*
     * Take the 20 byte array and print it in the requested base
     * e.g. log2base=1 => binary,  log2base=4 => hex
     */

    n = log2base;

        offset -= n;
        buf[j++] = itoa64f[(bits>>8)&mask];
    }
    buf[j++] = itoa64f[(bits>>8)&mask];
    buf[j++] = '\0';
    Tcl_AppendResult(interp, buf, NULL);
    if (contextnum > 0) {
	sha1ClientDataPtr->ctxtotalRead[contextnum] = -1;
    }
    return TCL_OK;

wrongArgs:
    Tcl_AppendResult(interp, "wrong # args: should be either:\n",
	    "  ",
	    Tcl_GetString(objv[0]),

 *
 *----------------------------------------------------------------------
 */

static void
Sha1_CmdDeleteProc(ClientData clientData)
{
    struct Sha1ClientData *sha1ClientDataPtr = clientData;
    
    /*
     * Release the sha1 contextes
     */
    
    ckfree(sha1ClientDataPtr->sha1Contexts);
    ckfree(sha1ClientDataPtr->ctxtotalRead);

    /*
     * Release the procedure client data
     */

    ckfree(sha1ClientDataPtr);
}


/*
 *----------------------------------------------------------------------
 *
 * Sample_Init --

extern "C" {
#endif  /* __cplusplus */
DLLEXPORT int
Sample_Init(
    Tcl_Interp* interp)		/* Tcl interpreter */
{
    Tcl_CmdInfo info;
    struct CmdClientData *cmdClientDataPtr;
    struct Sha1ClientData *sha1ClientDataPtr;

    /*
     * Require compatible TCL version.
     * Possible version requirement strings:
     * - "8.1-": 8.1 and any higher version
     * - "8.1": 8.1.x to 8.7.x
     * - "8.1 9": allow 8.1.x to 8.7.x and 9.x.x, but not 10.x.x
     * Note that Tcl_InitStubs is a macro, which is replaced by a Tcl version
     * check only, if TCL_STUBS is not defined (e.g. direct link, static build)
     */
    if (Tcl_InitStubs(interp, "8.1-", 0) == NULL) {
	return TCL_ERROR;
    }
    
    /*
     * Create and init my client data
     */
    cmdClientDataPtr = ckalloc(sizeof(struct Sha1ClientData));
    cmdClientDataPtr->sha1CmdTolken = NULL;
    cmdClientDataPtr->buildInfoCmdTolken = NULL;

    /*
     * Init the sha1 context queues
     */
    sha1ClientDataPtr = ckalloc(sizeof(struct Sha1ClientData));
    sha1ClientDataPtr->numcontexts = 1;
    sha1ClientDataPtr->sha1Contexts = (SHA1_CTX *) ckalloc(sizeof(SHA1_CTX));
    sha1ClientDataPtr->ctxtotalRead = (Tcl_Size *) ckalloc(sizeof(Tcl_Size));

    /*
     * Create the sha1 command.
     * Pass the client data pointer to the procedure, so the que data is available.
     * Also, register a delete proc to clear the sha1 queue on deletion.
     */

    cmdClientDataPtr->sha1CmdTolken = Tcl_CreateObjCommand(
	    interp, "sha1", (Tcl_ObjCmdProc *)Sha1_Cmd,
	    sha1ClientDataPtr, Sha1_CmdDeleteProc);

    /*
     * Create the buildinfo command if tcl supports it
     */

    if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) {
	cmdClientDataPtr->buildInfoCmdTolken = Tcl_CreateObjCommand(
		interp,
		"::sample::build-info",
		info.objProc, (void *)(
		    PACKAGE_VERSION "+" STRINGIFY(SAMPLE_VERSION_UUID)
#if defined(__clang__) && defined(__clang_major__)
			    ".clang-" STRINGIFY(__clang_major__)
#if __clang_minor__ < 10

			    ".static"
#endif
		), NULL);
    } else {
	/*
	 * No build-info command created. Save a NULL tolken.
	 */
	cmdClientDataPtr->buildInfoCmdTolken = NULL;
    }
    
    /*
     * FIXME: Now I have to beam cmdClientDataPtr to the unload procedure below.
     * I have no idea, how to do that. Thanks for any help.
     */

    /* Provide the current package */

    if (Tcl_PkgProvideEx(interp, PACKAGE_NAME, PACKAGE_VERSION, NULL) != TCL_OK) {
	return TCL_ERROR;
    }

extern "C" {
#endif  /* __cplusplus */
DLLEXPORT int
Sample_Unload(
    Tcl_Interp* interp,		/* Tcl interpreter */
    int flags)			/* interpreter or process detach */
{

    /* CLient data of the DLL */
    /* FIXME: this has to be beamed from the init procedure to this procedure */
    struct CmdClientData *cmdClientDataPtr = NULL;

    /* Remove the sha1 command */
    Tcl_DeleteCommandFromToken(interp, cmdClientDataPtr->sha1CmdTolken); 

    /* if created, also remove the build-info command */
    if (NULL != cmdClientDataPtr->buildInfoCmdTolken) {
	Tcl_DeleteCommandFromToken(interp, cmdClientDataPtr->buildInfoCmdTolken); 
    }
    
    /* free the client data */
    ckfree(cmdClientDataPtr);
    return TCL_OK;
}
#ifdef __cplusplus
}
#endif  /* __cplusplus */